X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Finsts.lisp;h=514f11698c2beed00de199de7be6a198f14fafdc;hb=22b819c0cd0ca0ea5be52ba280b9e9e0b8e86210;hp=d9dca7c22b28e17183a7ec5b6326f8cce8321c78;hpb=3c65762b927af861c9c8bc416e4cbac9a14ec0c3;p=sbcl.git diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index d9dca7c..514f116 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -19,6 +19,8 @@ (setf sb!disassem:*disassem-inst-alignment-bytes* 1) (deftype reg () '(unsigned-byte 3)) + +(def!constant +default-operand-size+ :dword) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) @@ -106,6 +108,14 @@ (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)) @@ -189,94 +199,94 @@ ;;;; disassembler argument types -(sb!disassem:define-argument-type displacement +(sb!disassem:define-arg-type displacement :sign-extend t :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-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 + :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)))) ;;; 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)) @@ -285,22 +295,22 @@ (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* @@ -333,7 +343,7 @@ (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) @@ -471,6 +481,12 @@ :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)) ;;;; This section was added by jrd, for fp instructions. @@ -548,9 +564,9 @@ ;; 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)) @@ -558,9 +574,9 @@ ;; 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 @@ -611,14 +627,14 @@ (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-lowtag)))) + 4 ; FIXME: sb!vm: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) @@ -678,7 +694,7 @@ (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)) @@ -693,7 +709,7 @@ (emit-absolute-fixup segment (make-fixup nil :code-object - (- (* (tn-offset thing) word-bytes) + (- (* (tn-offset thing) n-word-bytes) other-pointer-lowtag)))))) (ea (let* ((base (ea-base thing)) @@ -794,9 +810,7 @@ ;;;; 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+)) @@ -1039,6 +1053,11 @@ (emit-ea segment dst (reg-tn-encoding src))))) + +(define-instruction fs-segment-prefix (segment) + (:emitter + (emit-byte segment #x64))) + ;;;; flag control instructions ;;; CLC -- Clear Carry Flag. @@ -1117,7 +1136,7 @@ ((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 @@ -1129,7 +1148,7 @@ (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 @@ -1576,6 +1595,7 @@ ;;;; 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) @@ -1586,6 +1606,7 @@ (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) @@ -1609,19 +1630,33 @@ (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))) @@ -1637,10 +1672,10 @@ (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)) @@ -1651,10 +1686,10 @@ (defun emit-byte-displacement-backpatch (segment target) (emit-back-patch segment 1 - #'(lambda (segment posn) - (let ((disp (- (label-position target) (1+ posn)))) - (aver (<= -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 @@ -1668,39 +1703,38 @@ (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)) @@ -1786,21 +1820,21 @@ (cond (length-only (values 0 (1+ length) nil nil)) (t - (sb!kernel:copy-from-system-area sap (* byte-bits (1+ offset)) - vector (* word-bits + (sb!kernel:copy-from-system-area sap (* n-byte-bits (1+ offset)) + vector (* n-word-bits vector-data-offset) - (* length byte-bits)) + (* length n-byte-bits)) (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) @@ -1826,19 +1860,19 @@ ;; 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:fun-end-breakpoint-trap + (#.fun-end-breakpoint-trap (nt "function end breakpoint trap"))))) (define-instruction break (segment code)