X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Finsts.lisp;h=f93d920f2fafc3be68cde41cd76528ace401b720;hb=545fa4548b327804cf78afe38a2ecd94ced86162;hp=243b56de14b83e303360dea64686656519e5f3c0;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index 243b56d..f93d920 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -15,17 +15,6 @@ ;;; I wonder whether the separation of the disassembler from the ;;; virtual machine is valid or adds value. -(file-comment - "$Header$") - -;;; 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) @@ -202,7 +191,10 @@ (sb!disassem:define-argument-type displacement :sign-extend t - :use-label #'offset-next) + :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) @@ -288,12 +280,11 @@ (defun print-fp-reg (value stream dstate) (declare (ignore dstate)) (format stream "FR~D" value)) - (defun prefilter-fp-reg (value dstate) ;; just return it (declare (ignore dstate)) value) -) +) ; EVAL-WHEN (sb!disassem:define-argument-type fp-reg :prefilter #'prefilter-fp-reg :printer #'print-fp-reg) @@ -312,7 +303,7 @@ (princ (schar (symbol-name word-width) 0) stream))))) (eval-when (:compile-toplevel :load-toplevel :execute) -(defconstant conditions +(defparameter *conditions* '((:o . 0) (:no . 1) (:b . 2) (:nae . 2) (:c . 2) @@ -329,14 +320,13 @@ (:nl . 13) (:ge . 13) (:le . 14) (:ng . 14) (:nle . 15) (:g . 15))) - (defparameter *condition-name-vec* (let ((vec (make-array 16 :initial-element nil))) - (dolist (cond conditions) + (dolist (cond *conditions*) (when (null (aref vec (cdr cond))) (setf (aref vec (cdr cond)) (car cond)))) vec)) -);EVAL-WHEN +) ; EVAL-WHEN ;;; Set assembler parameters. (In CMU CL, this was done with ;;; a call to a macro DEF-ASSEMBLER-PARAMS.) @@ -347,7 +337,7 @@ :printer *condition-name-vec*) (defun conditional-opcode (condition) - (cdr (assoc condition conditions :test #'eq))) + (cdr (assoc condition *conditions* :test #'eq))) ;;;; disassembler instruction formats @@ -628,7 +618,7 @@ (- (+ (component-header-length) (or (label-position offset) 0)) - other-pointer-type)))) + other-pointer-lowtag)))) (emit-dword segment (or offset 0))))) (defun emit-relative-fixup (segment fixup) @@ -639,12 +629,13 @@ (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)) @@ -664,11 +655,11 @@ (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) @@ -703,7 +694,7 @@ (make-fixup nil :code-object (- (* (tn-offset thing) word-bytes) - other-pointer-type)))))) + other-pointer-lowtag)))))) (ea (let* ((base (ea-base thing)) (index (ea-index thing)) @@ -713,7 +704,7 @@ (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))) @@ -758,39 +749,39 @@ (defun byte-reg-p (thing) (and (tn-p thing) (eq (sb-name (sc-sb (tn-sc thing))) 'registers) - (member (sc-name (tn-sc thing)) byte-sc-names) + (member (sc-name (tn-sc thing)) *byte-sc-names*) t)) (defun byte-ea-p (thing) (typecase thing (ea (eq (ea-size thing) :byte)) (tn - (and (member (sc-name (tn-sc thing)) byte-sc-names) t)) + (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t)) (t nil))) (defun word-reg-p (thing) (and (tn-p thing) (eq (sb-name (sc-sb (tn-sc thing))) 'registers) - (member (sc-name (tn-sc thing)) word-sc-names) + (member (sc-name (tn-sc thing)) *word-sc-names*) t)) (defun word-ea-p (thing) (typecase thing (ea (eq (ea-size thing) :word)) - (tn (and (member (sc-name (tn-sc thing)) word-sc-names) t)) + (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t)) (t nil))) (defun dword-reg-p (thing) (and (tn-p thing) (eq (sb-name (sc-sb (tn-sc thing))) 'registers) - (member (sc-name (tn-sc thing)) dword-sc-names) + (member (sc-name (tn-sc thing)) *dword-sc-names*) t)) (defun dword-ea-p (thing) (typecase thing (ea (eq (ea-size thing) :dword)) (tn - (and (member (sc-name (tn-sc thing)) dword-sc-names) t)) + (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t)) (t nil))) (defun register-p (thing) @@ -814,17 +805,19 @@ (defun operand-size (thing) (typecase thing (tn + ;; FIXME: might as well be COND instead of having to use #. readmacro + ;; to hack up the code (case (sc-name (tn-sc thing)) - (#.dword-sc-names + (#.*dword-sc-names* :dword) - (#.word-sc-names + (#.*word-sc-names* :word) - (#.byte-sc-names + (#.*byte-sc-names* :byte) - ;; added by jrd. float-registers is a separate size (?) - (#.float-sc-names + ;; added by jrd: float-registers is a separate size (?) + (#.*float-sc-names* :float) - (#.double-sc-names + (#.*double-sc-names* :double) (t (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing)))))) @@ -904,7 +897,7 @@ (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)) @@ -912,12 +905,12 @@ (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) @@ -968,7 +961,7 @@ (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))) @@ -986,7 +979,7 @@ (: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))) @@ -1030,7 +1023,7 @@ (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)))) @@ -1038,7 +1031,7 @@ ;; 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) @@ -1242,7 +1235,7 @@ (: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)))) @@ -1285,7 +1278,7 @@ (: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)))) @@ -1294,7 +1287,7 @@ (: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)))) @@ -1340,7 +1333,7 @@ ;; 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) @@ -1518,7 +1511,7 @@ (: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))))) @@ -1526,7 +1519,7 @@ (: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))))) @@ -1540,7 +1533,7 @@ (: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))))) @@ -1548,7 +1541,7 @@ (: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))))) @@ -1556,7 +1549,7 @@ (: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))))) @@ -1660,7 +1653,7 @@ 1 #'(lambda (segment posn) (let ((disp (- (label-position target) (1+ posn)))) - (assert (<= -128 disp 127)) + (aver (<= -128 disp 127)) (emit-byte segment disp))))) (define-instruction jmp (segment cond &optional where) @@ -1794,7 +1787,7 @@ (values 0 (1+ length) nil nil)) (t (sb!kernel:copy-from-system-area sap (* byte-bits (1+ offset)) - vector (* word-bits + vector (* n-word-bits vector-data-offset) (* length byte-bits)) (collect ((sc-offsets) @@ -1845,7 +1838,7 @@ (nt "pending interrupt trap")) (#.sb!vm:halt-trap (nt "halt trap")) - (#.sb!vm:function-end-breakpoint-trap + (#.sb!vm:fun-end-breakpoint-trap (nt "function end breakpoint trap"))))) (define-instruction break (segment code) @@ -1930,16 +1923,16 @@ (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))) ;;;; fp instructions ;;;; @@ -2047,14 +2040,14 @@ (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))) @@ -2104,14 +2097,14 @@ (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))) @@ -2123,14 +2116,14 @@ (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))) @@ -2158,7 +2151,7 @@ (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))) @@ -2208,7 +2201,7 @@ (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))) @@ -2220,7 +2213,7 @@ (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))) @@ -2431,7 +2424,7 @@ ;; XX Printer conflicts with frstor ;; (:printer floating-point ((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)))