insts.lisp

开源跨平台Lisp编译器

           (emit-sib-byte segment ss index base)))
       (cond ((= mod #b01)
              (emit-byte segment disp))
             ((or (= mod #b10) (null base))
              (if (fixup-p disp)
                  (emit-absolute-fixup segment disp)
                  (emit-signed-dword segment disp))))))
    (fixup
     (typecase (fixup-offset thing)
       (label
        (emit-label-rip segment thing reg))
       (t
        (emit-mod-reg-r/m-byte segment #b00 reg #b100)
        (emit-sib-byte segment 0 #b100 #b101)
        (emit-absolute-fixup segment thing))))))

(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*)
       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))
    (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*)
       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))
    (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*)
       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))
    (t nil)))

(defun qword-reg-p (thing)
  (and (tn-p thing)
       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
       (member (sc-name (tn-sc thing)) *qword-sc-names*)
       t))

(defun qword-ea-p (thing)
  (typecase thing
    (ea (eq (ea-size thing) :qword))
    (tn
     (and (member (sc-name (tn-sc thing)) *qword-sc-names*) t))
    (t nil)))

;;; Return true if THING is a general-purpose register TN.
(defun register-p (thing)
  (and (tn-p thing)
       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))

(defun accumulator-p (thing)
  (and (register-p thing)
       (= (tn-offset thing) 0)))

;;; Return true if THING is an XMM register TN.
(defun xmm-register-p (thing)
  (and (tn-p thing)
       (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))


;;;; utilities

(def!constant +operand-size-prefix-byte+ #b01100110)

(defun maybe-emit-operand-size-prefix (segment size)
  (unless (or (eq size :byte)
              (eq size :qword)          ; REX prefix handles this
              (eq size +default-operand-size+))
    (emit-byte segment +operand-size-prefix-byte+)))

;;; A REX prefix must be emitted if at least one of the following
;;; conditions is true:
;;  1. The operand size is :QWORD and the default operand size of the
;;     instruction is not :QWORD.
;;; 2. The instruction references an extended register.
;;; 3. The instruction references one of the byte registers SIL, DIL,
;;;    SPL or BPL.

;;; Emit a REX prefix if necessary. OPERAND-SIZE is used to determine
;;; whether to set REX.W. Callers pass it explicitly as :DO-NOT-SET if
;;; this should not happen, for example because the instruction's
;;; default operand size is qword. R, X and B are NIL or TNs specifying
;;; registers the encodings of which are extended with the REX.R, REX.X
;;; and REX.B bit, respectively. To determine whether one of the byte
;;; registers is used that can only be accessed using a REX prefix, we
;;; need only to test R and B, because X is only used for the index
;;; register of an effective address and therefore never byte-sized.
;;; For R we can avoid to calculate the size of the TN because it is
;;; always OPERAND-SIZE. The size of B must be calculated here because
;;; B can be address-sized (if it is the base register of an effective
;;; address), of OPERAND-SIZE (if the instruction operates on two
;;; registers) or of some different size (in the instructions that
;;; combine arguments of different sizes: MOVZX, MOVSX, MOVSXD and
;;; several SSE instructions, e.g. CVTSD2SI). We don't distinguish
;;; between general-purpose and floating point registers for this cause
;;; because only general-purpose registers can be byte-sized at all.
(defun maybe-emit-rex-prefix (segment operand-size r x b)
  (declare (type (member nil :byte :word :dword :qword :do-not-set)
                 operand-size)
           (type (or null tn) r x b))
  (labels ((if-hi (r)
             (if (and r (> (tn-offset r)
                           ;; offset of r8 is 16, offset of xmm8 is 8
                           (if (eq (sb-name (sc-sb (tn-sc r)))
                                   'float-registers)
                               7
                               15)))
                 1
                 0))
           (reg-4-7-p (r)
             ;; Assuming R is a TN describing a general-purpose
             ;; register, return true if it references register
             ;; 4 upto 7.
             (<= 8 (tn-offset r) 15)))
    (let ((rex-w (if (eq operand-size :qword) 1 0))
          (rex-r (if-hi r))
          (rex-x (if-hi x))
          (rex-b (if-hi b)))
      (when (or (not (zerop (logior rex-w rex-r rex-x rex-b)))
                (and r
                     (eq operand-size :byte)
                     (reg-4-7-p r))
                (and b
                     (eq (operand-size b) :byte)
                     (reg-4-7-p b)))
        (emit-rex-byte segment #b0100 rex-w rex-r rex-x rex-b)))))

;;; Emit a REX prefix if necessary. The operand size is determined from
;;; THING or can be overwritten by OPERAND-SIZE. This and REG are always
;;; passed to MAYBE-EMIT-REX-PREFIX. Additionally, if THING is an EA we
;;; pass its index and base registers, if it is a register TN, we pass
;;; only itself.
;;; In contrast to EMIT-EA above, neither stack TNs nor fixups need to
;;; be treated specially here: If THING is a stack TN, neither it nor
;;; any of its components are passed to MAYBE-EMIT-REX-PREFIX which
;;; works correctly because stack references always use RBP as the base
;;; register and never use an index register so no extended registers
;;; need to be accessed. Fixups are assembled using an addressing mode
;;; of displacement-only or RIP-plus-displacement (see EMIT-EA), so may
;;; not reference an extended register. The displacement-only addressing
;;; mode requires that REX.X is 0, which is ensured here.
(defun maybe-emit-rex-for-ea (segment thing reg &key operand-size)
  (declare (type (or ea tn fixup) thing)
           (type (or null tn) reg)
           (type (member nil :byte :word :dword :qword :do-not-set)
                 operand-size))
  (let ((ea-p (ea-p thing)))
    (maybe-emit-rex-prefix segment
                           (or operand-size (operand-size thing))
                           reg
                           (and ea-p (ea-index thing))
                           (cond (ea-p (ea-base thing))
                                 ((and (tn-p thing)
                                       (member (sb-name (sc-sb (tn-sc thing)))
                                               '(float-registers registers)))
                                  thing)
                                 (t nil)))))

(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))
       (#.*qword-sc-names*
        :qword)
       (#.*dword-sc-names*
        :dword)
       (#.*word-sc-names*
        :word)
       (#.*byte-sc-names*
        :byte)
       ;; added by jrd: float-registers is a separate size (?)
       ;; The only place in the code where we are called with THING
       ;; being a float-register is in MAYBE-EMIT-REX-PREFIX when it
       ;; checks whether THING is a byte register. Thus our result in
       ;; these cases could as well be :dword and :qword. I leave it as
       ;; :float and :double which is more likely to trigger an aver
       ;; instead of silently doing the wrong thing in case this
       ;; situation should change. Lutz Euler, 2005-10-23.
       (#.*float-sc-names*
        :float)
       (#.*double-sc-names*
        :double)
       (t
        (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
    (ea
     (ea-size thing))
    (fixup
     ;; GNA.  Guess who spelt "flavor" correctly first time round?
     ;; There's a strong argument in my mind to change all uses of
     ;; "flavor" to "kind": and similarly with some misguided uses of
     ;; "type" here and there.  -- CSR, 2005-01-06.
     (case (fixup-flavor thing)
       ((:foreign-dataref) :qword)))
    (t
     nil)))

(defun matching-operand-size (dst src)
  (let ((dst-size (operand-size dst))
        (src-size (operand-size src)))
    (if dst-size
        (if src-size
            (if (eq dst-size src-size)
                dst-size
                (error "size mismatch: ~S is a ~S and ~S is a ~S."
                       dst dst-size src src-size))
            dst-size)
        (if src-size
            src-size
            (error "can't tell the size of either ~S or ~S" dst src)))))

;;; Except in a very few cases (MOV instructions A1, A3 and B8 - BF)
;;; we expect dword data bytes even when 64 bit work is being done.
;;; But A1 and A3 are currently unused and B8 - BF use EMIT-QWORD
;;; directly, so we emit all quad constants as dwords, additionally
;;; making sure that they survive the sign-extension to 64 bits
;;; unchanged.
(defun emit-sized-immediate (segment size value)
  (ecase size
    (:byte
     (emit-byte segment value))
    (:word
     (emit-word segment value))
    (:dword
     (emit-dword segment value))
    (:qword
     (emit-signed-dword segment value))))

;;;; general data transfer

;;; This is the part of the MOV instruction emitter that does moving
;;; of an immediate value into a qword register. We go to some length
;;; to achieve the shortest possible encoding.
(defun emit-immediate-move-to-qword-register (segment dst src)
  (declare (type integer src))
  (cond ((typep src '(unsigned-byte 32))
         ;; We use the B8 - BF encoding with an operand size of 32 bits
         ;; here and let the implicit zero-extension fill the upper half
         ;; of the 64-bit destination register. Instruction size: five
         ;; or six bytes. (A REX prefix will be emitted only if the
         ;; destination is an extended register.)
         (maybe-emit-rex-prefix segment :dword nil nil dst)
         (emit-byte-with-reg segment #b10111 (reg-tn-encoding dst))
         (emit-dword segment src))
        (t
         (maybe-emit-rex-prefix segment :qword nil nil dst)
         (cond ((typep src '(signed-byte 32))
                ;; Use the C7 encoding that takes a 32-bit immediate and
                ;; sign-extends it to 64 bits. Instruction size: seven
                ;; bytes.
                (emit-byte segment #b11000111)
                (emit-mod-reg-r/m-byte segment #b11 #b000
                                       (reg-tn-encoding dst))
                (emit-signed-dword segment src))
               ((<= (- (expt 2 64) (expt 2 31))
                    src
                    (1- (expt 2 64)))
                ;; This triggers on positive integers of 64 bits length
                ;; with the most significant 33 bits being 1. We use the
                ;; same encoding as in the previous clause.
                (emit-byte segment #b11000111)
                (emit-mod-reg-r/m-byte segment #b11 #b000
                                       (reg-tn-encoding dst))
                (emit-signed-dword segment (- src (expt 2 64))))
               (t
                ;; We need a full 64-bit immediate. Instruction size:
                ;; ten bytes.
                (emit-byte-with-reg segment #b10111 (reg-tn-encoding dst))
                (emit-qword segment src))))))

(define-instruction mov (segment dst src)
  ;; immediate to register
  (:printer reg ((op #b1011) (imm nil :type 'signed-imm-data))
            '(:name :tab reg ", " imm))
  (:printer rex-reg ((op #b1011) (imm nil :type 'signed-imm-data-upto-qword))
            '(:name :tab reg ", " imm))
  ;; absolute mem to/from accumulator
  (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
            `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
  ;; register to/from register/memory
  (:printer reg-reg/mem-dir ((op #b100010)))
  (:printer rex-reg-reg/mem-dir ((op #b100010)))
  (:printer x66-reg-reg/mem-dir ((op #b100010)))
  (:printer x66-rex-reg-reg/mem-dir ((op #b100010)))
  ;; immediate to register/memory
  (:printer reg/mem-imm ((op '(#b1100011 #b000))))
  (:printer rex-reg/mem-imm ((op '(#b1100011 #b000))))

  (:emitter
   (let ((size (matching-operand-size dst src)))
     (maybe-emit-operand-size-prefix segment size)
     (cond ((register-p dst)
            (cond ((integerp src)
                   (cond ((eq size :qword)
                          (emit-immediate-move-to-qword-register segment
                                                                 dst src))