insts.lisp

开源跨平台Lisp编译器

;;;; logic

(defun emit-shift-inst (segment dst amount opcode)
  (let ((size (operand-size dst)))
    (maybe-emit-operand-size-prefix segment size)
    (multiple-value-bind (major-opcode immed)
        (case amount
          (:cl (values #b11010010 nil))
          (1 (values #b11010000 nil))
          (t (values #b11000000 t)))
      (emit-byte segment
                 (if (eq size :byte) major-opcode (logior major-opcode 1)))
      (emit-ea segment dst opcode)
      (when immed
        (emit-byte segment amount)))))

(eval-when (:compile-toplevel :execute)
  (defun shift-inst-printer-list (subop)
    `((reg/mem ((op (#b1101000 ,subop)))
               (:name :tab reg/mem ", 1"))
      (reg/mem ((op (#b1101001 ,subop)))
               (:name :tab reg/mem ", " 'cl))
      (reg/mem-imm ((op (#b1100000 ,subop))
                    (imm nil :type signed-imm-byte))))))

(define-instruction rol (segment dst amount)
  (:printer-list
   (shift-inst-printer-list #b000))
  (:emitter
   (emit-shift-inst segment dst amount #b000)))

(define-instruction ror (segment dst amount)
  (:printer-list
   (shift-inst-printer-list #b001))
  (:emitter
   (emit-shift-inst segment dst amount #b001)))

(define-instruction rcl (segment dst amount)
  (:printer-list
   (shift-inst-printer-list #b010))
  (:emitter
   (emit-shift-inst segment dst amount #b010)))

(define-instruction rcr (segment dst amount)
  (:printer-list
   (shift-inst-printer-list #b011))
  (:emitter
   (emit-shift-inst segment dst amount #b011)))

(define-instruction shl (segment dst amount)
  (:printer-list
   (shift-inst-printer-list #b100))
  (:emitter
   (emit-shift-inst segment dst amount #b100)))

(define-instruction shr (segment dst amount)
  (:printer-list
   (shift-inst-printer-list #b101))
  (:emitter
   (emit-shift-inst segment dst amount #b101)))

(define-instruction sar (segment dst amount)
  (:printer-list
   (shift-inst-printer-list #b111))
  (:emitter
   (emit-shift-inst segment dst amount #b111)))

(defun emit-double-shift (segment opcode dst src amt)
  (let ((size (matching-operand-size dst src)))
    (when (eq size :byte)
      (error "Double shifts can only be used with words."))
    (maybe-emit-operand-size-prefix segment size)
    (emit-byte segment #b00001111)
    (emit-byte segment (dpb opcode (byte 1 3)
                            (if (eq amt :cl) #b10100101 #b10100100)))
    #+nil
    (emit-ea segment dst src)
    (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
    (unless (eq amt :cl)
      (emit-byte segment amt))))

(eval-when (:compile-toplevel :execute)
  (defun double-shift-inst-printer-list (op)
    `(#+nil
      (ext-reg-reg/mem-imm ((op ,(logior op #b10))
                            (imm nil :type signed-imm-byte)))
      (ext-reg-reg/mem ((op ,(logior op #b10)))
         (:name :tab reg/mem ", " reg ", " 'cl)))))

(define-instruction shld (segment dst src amt)
  (:declare (type (or (member :cl) (mod 32)) amt))
  (:printer-list (double-shift-inst-printer-list #b1010000))
  (:emitter
   (emit-double-shift segment #b0 dst src amt)))

(define-instruction shrd (segment dst src amt)
  (:declare (type (or (member :cl) (mod 32)) amt))
  (:printer-list (double-shift-inst-printer-list #b1010100))
  (:emitter
   (emit-double-shift segment #b1 dst src amt)))

(define-instruction and (segment dst src)
  (:printer-list
   (arith-inst-printer-list #b100))
  (:emitter
   (emit-random-arith-inst "AND" segment dst src #b100)))

(define-instruction test (segment this that)
  (:printer accum-imm ((op #b1010100)))
  (:printer reg/mem-imm ((op '(#b1111011 #b000))))
  (:printer reg-reg/mem ((op #b1000010)))
  (:emitter
   (let ((size (matching-operand-size this that)))
     (maybe-emit-operand-size-prefix segment size)
     (flet ((test-immed-and-something (immed something)
              (cond ((accumulator-p something)
                     (emit-byte segment
                                (if (eq size :byte) #b10101000 #b10101001))
                     (emit-sized-immediate segment size immed))
                    (t
                     (emit-byte segment
                                (if (eq size :byte) #b11110110 #b11110111))
                     (emit-ea segment something #b000)
                     (emit-sized-immediate segment size immed))))
            (test-reg-and-something (reg something)
              (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
              (emit-ea segment something (reg-tn-encoding reg))))
       (cond ((integerp that)
              (test-immed-and-something that this))
             ((integerp this)
              (test-immed-and-something this that))
             ((register-p this)
              (test-reg-and-something this that))
             ((register-p that)
              (test-reg-and-something that this))
             (t
              (error "bogus operands for TEST: ~S and ~S" this that)))))))

;;; Emit the most compact form of the test immediate instruction,
;;; using an 8 bit test when the immediate is only 8 bits and the
;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
;;; control stack.
(defun emit-optimized-test-inst (x y)
  (typecase y
    ((unsigned-byte 7)
     (let ((offset (tn-offset x)))
       (cond ((and (sc-is x any-reg descriptor-reg)
                   (or (= offset eax-offset) (= offset ebx-offset)
                       (= offset ecx-offset) (= offset edx-offset)))
              (inst test (make-random-tn :kind :normal
                                         :sc (sc-or-lose 'byte-reg)
                                         :offset offset)
                    y))
             ((sc-is x control-stack)
              (inst test (make-ea :byte :base ebp-tn
                                  :disp (- (* (1+ offset) n-word-bytes)))
                    y))
             (t
              (inst test x y)))))
    (t
     (inst test x y))))

(define-instruction or (segment dst src &optional prefix)
  (:printer-list
   (arith-inst-printer-list #b001))
  (:emitter
   (emit-prefix segment prefix)
   (emit-random-arith-inst "OR" segment dst src #b001)))

(define-instruction xor (segment dst src &optional prefix)
  (:printer-list
   (arith-inst-printer-list #b110))
  (:emitter
   (emit-prefix segment prefix)
   (emit-random-arith-inst "XOR" segment dst src #b110)))

(define-instruction not (segment dst)
  (:printer reg/mem ((op '(#b1111011 #b010))))
  (:emitter
   (let ((size (operand-size dst)))
     (maybe-emit-operand-size-prefix segment size)
     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
     (emit-ea segment dst #b010))))

;;;; string manipulation

(define-instruction cmps (segment size)
  (:printer string-op ((op #b1010011)))
  (:emitter
   (maybe-emit-operand-size-prefix segment size)
   (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))

(define-instruction ins (segment acc)
  (:printer string-op ((op #b0110110)))
  (:emitter
   (let ((size (operand-size acc)))
     (aver (accumulator-p acc))
     (maybe-emit-operand-size-prefix segment size)
     (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))

(define-instruction lods (segment acc)
  (:printer string-op ((op #b1010110)))
  (:emitter
   (let ((size (operand-size acc)))
     (aver (accumulator-p acc))
     (maybe-emit-operand-size-prefix segment size)
     (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))

(define-instruction movs (segment size)
  (:printer string-op ((op #b1010010)))
  (:emitter
   (maybe-emit-operand-size-prefix segment size)
   (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))

(define-instruction outs (segment acc)
  (:printer string-op ((op #b0110111)))
  (:emitter
   (let ((size (operand-size acc)))
     (aver (accumulator-p acc))
     (maybe-emit-operand-size-prefix segment size)
     (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))

(define-instruction scas (segment acc)
  (:printer string-op ((op #b1010111)))
  (:emitter
   (let ((size (operand-size acc)))
     (aver (accumulator-p acc))
     (maybe-emit-operand-size-prefix segment size)
     (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))

(define-instruction stos (segment acc)
  (:printer string-op ((op #b1010101)))
  (:emitter
   (let ((size (operand-size acc)))
     (aver (accumulator-p acc))
     (maybe-emit-operand-size-prefix segment size)
     (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))

(define-instruction xlat (segment)
  (:printer byte ((op #b11010111)))
  (:emitter
   (emit-byte segment #b11010111)))

(define-instruction rep (segment)
  (:emitter
   (emit-byte segment #b11110010)))

(define-instruction repe (segment)
  (:printer byte ((op #b11110011)))
  (:emitter
   (emit-byte segment #b11110011)))

(define-instruction repne (segment)
  (:printer byte ((op #b11110010)))
  (:emitter
   (emit-byte segment #b11110010)))


;;;; 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)
       (error "can't scan bytes: ~S" src))
     (maybe-emit-operand-size-prefix segment size)
     (emit-byte segment #b00001111)
     (emit-byte segment #b10111100)
     (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)
       (error "can't scan bytes: ~S" src))
     (maybe-emit-operand-size-prefix segment size)
     (emit-byte segment #b00001111)
     (emit-byte segment #b10111101)
     (emit-ea segment src (reg-tn-encoding dst)))))

(defun emit-bit-test-and-mumble (segment src index opcode)
  (let ((size (operand-size src)))
    (when (eq size :byte)
      (error "can't scan bytes: ~S" src))
    (maybe-emit-operand-size-prefix segment size)
    (emit-byte segment #b00001111)
    (cond ((integerp index)
           (emit-byte segment #b10111010)
           (emit-ea segment src opcode)
           (emit-byte segment index))
          (t
           (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)))


;;;; control transfer

(define-instruction call (segment where)
  (:printer near-jump ((op #b11101000)))
  (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
  (:emitter
   (typecase where
     (label
      (emit-byte segment #b11101000)
      (emit-back-patch segment
                       4
                       (lambda (segment posn)
                         (emit-dword segment
                                     (- (label-position where)
                                        (+ posn 4))))))
     (fixup
      (emit-byte segment #b11101000)
      (emit-relative-fixup segment where))
     (t
      (emit-byte segment #b11111111)
      (emit-ea segment where #b010)))))

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

(