insts.lisp

开源跨平台Lisp编译器

           (t
            (format stream "+~A" (ea-disp ea))))
         (write-char #\] stream))))

(defun emit-ea (segment thing reg &optional allow-constants)
  (etypecase thing
    (tn
     (ecase (sb-name (sc-sb (tn-sc thing)))
       (registers
        (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 (frame-byte-offset (tn-offset thing))))
          (cond ((<= -128 disp 127)
                 (emit-mod-reg-r/m-byte segment #b01 reg #b101)
                 (emit-byte segment disp))
                (t
                 (emit-mod-reg-r/m-byte segment #b10 reg #b101)
                 (emit-dword segment disp)))))
       (constant
        (unless allow-constants
          (error
           "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
        (emit-mod-reg-r/m-byte segment #b00 reg #b101)
        (emit-absolute-fixup segment
                             (make-fixup nil
                                         :code-object
                                         (- (* (tn-offset thing) n-word-bytes)
                                            other-pointer-lowtag))))))
    (ea
     (let* ((base (ea-base thing))
            (index (ea-index thing))
            (scale (ea-scale thing))
            (disp (ea-disp thing))
            (mod (cond ((or (null base)
                            (and (eql disp 0)
                                 (not (= (reg-tn-encoding base) #b101))))
                        #b00)
                       ((and (fixnump disp) (<= -128 disp 127))
                        #b01)
                       (t
                        #b10)))
            (r/m (cond (index #b100)
                       ((null base) #b101)
                       (t (reg-tn-encoding base)))))
       (emit-mod-reg-r/m-byte segment mod reg r/m)
       (when (= r/m #b100)
         (let ((ss (1- (integer-length scale)))
               (index (if (null index)
                          #b100
                          (let ((index (reg-tn-encoding index)))
                            (if (= index #b100)
                                (error "can't index off of ESP")
                                index))))
               (base (if (null base)
                         #b101
                         (reg-tn-encoding base))))
           (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-dword segment disp))))))
    (fixup
     (emit-mod-reg-r/m-byte segment #b00 reg #b101)
     (emit-absolute-fixup segment thing))))

(defun fp-reg-tn-p (thing)
  (and (tn-p thing)
       (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))

;;; like the above, but for fp-instructions--jrd
(defun emit-fp-op (segment thing op)
  (if (fp-reg-tn-p thing)
      (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
                                                 (byte 3 0)
                                                 #b11000000)))
    (emit-ea segment thing op)))

(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 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)))

;;;; utilities

(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+))
    (emit-byte segment +operand-size-prefix-byte+)))

(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)
       (#.*word-sc-names*
        :word)
       (#.*byte-sc-names*
        :byte)
       ;; added by jrd: float-registers is a separate size (?)
       (#.*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))
    (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)))))

(defun emit-sized-immediate (segment size value)
  (ecase size
    (:byte
     (emit-byte segment value))
    (:word
     (emit-word segment value))
    (:dword
     (emit-dword segment value))))

(defun toggle-word-width (chunk inst stream dstate)
  (declare (ignore chunk inst stream))
  (let ((word-width (or (sb!disassem:dstate-get-prop dstate 'word-width)
                        +default-operand-size+)))
    (setf (sb!disassem:dstate-get-prop dstate 'word-width)
          (ecase word-width
            (:word :dword)
            (:dword :word)))))

;;; This is a "prefix" instruction, which means that it modifies the
;;; following instruction in some way without having an actual
;;; mnemonic of its own.
(define-instruction operand-size-prefix (segment)
  (:printer byte ((op +operand-size-prefix-byte+))
            nil                         ; don't actually print it
            :control #'toggle-word-width))

;;;; general data transfer

(define-instruction mov (segment dst src &optional prefix)
  ;; immediate to register
  (:printer reg ((op #b1011) (imm nil :type 'imm-data))
            '(: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)))
  ;; immediate to register/memory
  (:printer reg/mem-imm ((op '(#b1100011 #b000))))

  (:emitter
   (emit-prefix segment prefix)
   (let ((size (matching-operand-size dst src)))
     (maybe-emit-operand-size-prefix segment size)
     (cond ((register-p dst)
            (cond ((integerp src)
                   (emit-byte-with-reg segment
                                       (if (eq size :byte)
                                           #b10110
                                           #b10111)
                                       (reg-tn-encoding dst))
                   (emit-sized-immediate segment size src))
                  ((and (fixup-p src) (accumulator-p dst))
                   (emit-byte segment
                              (if (eq size :byte)
                                  #b10100000
                                  #b10100001))
                   (emit-absolute-fixup segment src))
                  (t
                   (emit-byte segment
                              (if (eq size :byte)
                                  #b10001010
                                  #b10001011))
                   (emit-ea segment src (reg-tn-encoding dst) t))))
           ((and (fixup-p dst) (accumulator-p src))
            (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
            (emit-absolute-fixup segment dst))
           ((integerp src)
            (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
            (emit-ea segment dst #b000)
            (emit-sized-immediate segment size src))
           ((register-p src)
            (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
            (emit-ea segment dst (reg-tn-encoding src)))
           ((fixup-p src)
            (aver (eq size :dword))
            (emit-byte segment #b11000111)
            (emit-ea segment dst #b000)
            (emit-absolute-fixup segment src))
           (t
            (error "bogus arguments to MOV: ~S ~S" dst src))))))

(defun emit-move-with-extension (segment dst src opcode)
  (aver (register-p dst))
  (let ((dst-size (operand-size dst))
        (src-size (operand-size src)))
    (ecase dst-size
      (:word
       (aver (eq src-size :byte))
       (maybe-emit-operand-size-prefix segment :word)
       (emit-byte segment #b00001111)
       (emit-byte segment opcode)
       (emit-ea segment src (reg-tn-encoding dst)))
      (:dword
       (ecase src-size
         (:byte
          (maybe-emit-operand-size-prefix segment :dword)
          (emit-byte segment #b00001111)
          (emit-byte segment opcode)
          (emit-ea segment src (reg-tn-encoding dst)))
         (:word
          (emit-byte segment #b00001111)
          (emit-byte segment (logior opcode 1))
          (emit-ea segment src (reg-tn-encoding dst))))))))

(define-instruction movsx (segment dst src)
  (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg)))
  (:emitter (emit-move-with-extension segment dst src #b10111110)))

(define-instruction movzx (segment dst src)
  (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg)))
  (:emitter (emit-move-with-extension segment dst src #b10110110)))

(define-instruction push (segment src &optional prefix)
  ;; register
  (:printer reg-no-width ((op #b01010)))
  ;; register/memory
  (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
  ;; immediate
  (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
            '(:name :tab imm))
  (:printer byte ((op #b01101000) (imm nil :type 'imm-word))
            '(:name :tab imm))
  ;; ### segment registers?

  (:emitter
   (emit-prefix segment prefix)
   (cond ((integerp src)
          (cond ((<= -128 src 127)
                 (emit-byte segment #b01101010)
                 (emit-byte segment src))
                (t
                 (emit-byte segment #b01101000)
                 (emit-dword segment src))))
         ((fixup-p src)
          ;; Interpret the fixup as an immediate dword to push.
          (emit-byte segment #b01101000)
          (emit-absolute-fixup segment src))
         (t
          (let ((size (operand-size src)))
            (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)))
                  (t
                   (emit-byte segment #b11111111)
                   (emit-ea segment src #b110 t))))))))

(define-instruction pusha (segment)
  (:printer byte ((op #b01100000)))
  (:emitter
   (emit-byte segment #b01100000)))

(define-instruction pop (segment dst)
  (:printer reg-no-width ((op #b01011)))
  (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
  (:emitter
   (let ((size (operand-size dst)))
     (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)))
           (t
            (emit-byte segment #b10001111)
            (emit-ea segment dst #b000))))))

(define-instruction popa (segment)
  (:printer byte ((op #b01100001)))
  (:emitter
   (emit-byte segment #b01100001)))

(define-instruction xchg (segment operand1 operand2)
  ;; Register with accumulator.
  (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
  ;; Register/Memory with Register.
  (:printer reg-reg/mem ((op #b1000011)))
  (:emitter
   (let ((size (matching-operand-size operand1 operand2)))
     (maybe-emit-operand-size-prefix segment size)
     (labels ((xchg-acc-with-something (acc something)
                (if (and (not (eq size :byte)) (register-p something))
                    (emit-byte-with-reg segment
                                        #b10010
                                        (reg-tn-encoding something))
                    (xchg-reg-with-something acc something)))
              (xchg-reg-with-something (reg something)
                (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
                (emit-ea segment something (reg-tn-encoding reg))))
       (cond ((accumulator-p operand1)