insts.lisp

开源跨平台Lisp编译器

(sb!disassem:define-instruction-format (ext-rex-reg-xmm/mem 40
                                        :default-printer
                                        '(:name :tab reg ", " reg/mem))
  (prefix  :field (byte 8 0))
  (rex     :field (byte 4 12)   :value #b0100)
  (wrxb    :field (byte 4 8)    :type 'wrxb)
  (x0f     :field (byte 8 16)   :value #x0f)
  (op      :field (byte 8 24))
  (reg/mem :fields (list (byte 2 38) (byte 3 32))
                                :type 'sized-xmmreg/mem)
  (reg     :field (byte 3 35)   :type 'reg))

(sb!disassem:define-instruction-format (string-op 8
                                     :include 'simple
                                     :default-printer '(:name width)))

(sb!disassem:define-instruction-format (rex-string-op 16
                                     :include 'rex-simple
                                     :default-printer '(:name width)))

(sb!disassem:define-instruction-format (short-cond-jump 16)
  (op    :field (byte 4 4))
  (cc    :field (byte 4 0) :type 'condition-code)
  (label :field (byte 8 8) :type 'displacement))

(sb!disassem:define-instruction-format (short-jump 16
                                     :default-printer '(:name :tab label))
  (const :field (byte 4 4) :value #b1110)
  (op    :field (byte 4 0))
  (label :field (byte 8 8) :type 'displacement))

(sb!disassem:define-instruction-format (near-cond-jump 16)
  (op    :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
  (cc    :field (byte 4 8) :type 'condition-code)
  ;; 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))))

(sb!disassem:define-instruction-format (near-jump 8
                                     :default-printer '(:name :tab label))
  (op    :field (byte 8 0))
  ;; 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))))


(sb!disassem:define-instruction-format (cond-set 24
                                     :default-printer '('set cc :tab reg/mem))
  (prefix :field (byte 8 0) :value #b00001111)
  (op    :field (byte 4 12) :value #b1001)
  (cc    :field (byte 4 8) :type 'condition-code)
  (reg/mem :fields (list (byte 2 22) (byte 3 16))
           :type 'sized-byte-reg/mem)
  (reg     :field (byte 3 19)   :value #b000))

(sb!disassem:define-instruction-format (cond-move 24
                                     :default-printer
                                        '('cmov cc :tab reg ", " reg/mem))
  (prefix  :field (byte 8 0)    :value #b00001111)
  (op      :field (byte 4 12)   :value #b0100)
  (cc      :field (byte 4 8)    :type 'condition-code)
  (reg/mem :fields (list (byte 2 22) (byte 3 16))
                                :type 'reg/mem)
  (reg     :field (byte 3 19)   :type 'reg))

(sb!disassem:define-instruction-format (rex-cond-move 32
                                     :default-printer
                                        '('cmov cc :tab reg ", " reg/mem))
  (rex     :field (byte 4 4)   :value #b0100)
  (wrxb    :field (byte 4 0)    :type 'wrxb)
  (prefix  :field (byte 8 8)    :value #b00001111)
  (op      :field (byte 4 20)   :value #b0100)
  (cc      :field (byte 4 16)    :type 'condition-code)
  (reg/mem :fields (list (byte 2 30) (byte 3 24))
                                :type 'reg/mem)
  (reg     :field (byte 3 27)   :type 'reg))

(sb!disassem:define-instruction-format (enter-format 32
                                     :default-printer '(:name
                                                        :tab disp
                                                        (:unless (:constant 0)
                                                          ", " level)))
  (op :field (byte 8 0))
  (disp :field (byte 16 8))
  (level :field (byte 8 24)))

;;; Single byte instruction with an immediate byte argument.
(sb!disassem:define-instruction-format (byte-imm 16
                                     :default-printer '(:name :tab code))
 (op :field (byte 8 0))
 (code :field (byte 8 8)))

;;; Two byte instruction with an immediate byte argument.
;;;
(sb!disassem:define-instruction-format (word-imm 24
                                     :default-printer '(:name :tab code))
  (op :field (byte 16 0))
  (code :field (byte 8 16)))


;;;; primitive emitters

(define-bitfield-emitter emit-word 16
  (byte 16 0))

(define-bitfield-emitter emit-dword 32
  (byte 32 0))

;;; Most uses of dwords are as displacements or as immediate values in
;;; 64-bit operations. In these cases they are sign-extended to 64 bits.
;;; EMIT-DWORD is unsuitable there because it accepts values of type
;;; (OR (SIGNED-BYTE 32) (UNSIGNED-BYTE 32)), so we provide a more
;;; restricted emitter here.
(defun emit-signed-dword (segment value)
  (declare (type segment segment)
           (type (signed-byte 32) value))
  (declare (inline emit-dword))
  (emit-dword segment value))

(define-bitfield-emitter emit-qword 64
  (byte 64 0))

(define-bitfield-emitter emit-byte-with-reg 8
  (byte 5 3) (byte 3 0))

(define-bitfield-emitter emit-mod-reg-r/m-byte 8
  (byte 2 6) (byte 3 3) (byte 3 0))

(define-bitfield-emitter emit-sib-byte 8
  (byte 2 6) (byte 3 3) (byte 3 0))

(define-bitfield-emitter emit-rex-byte 8
  (byte 4 4) (byte 1 3) (byte 1 2) (byte 1 1) (byte 1 0))



;;;; fixup emitters

(defun emit-absolute-fixup (segment fixup &optional quad-p)
  (note-fixup segment (if quad-p :absolute64 :absolute) fixup)
  (let ((offset (fixup-offset fixup)))
    (if (label-p offset)
        (emit-back-patch segment
                         (if quad-p 8 4)
                         (lambda (segment posn)
                           (declare (ignore posn))
                           (let ((val  (- (+ (component-header-length)
                                             (or (label-position offset)
                                                 0))
                                          other-pointer-lowtag)))
                             (if quad-p
                                 (emit-qword segment val)
                                 (emit-signed-dword segment val)))))
        (if quad-p
            (emit-qword segment (or offset 0))
            (emit-signed-dword segment (or offset 0))))))

(defun emit-relative-fixup (segment fixup)
  (note-fixup segment :relative fixup)
  (emit-signed-dword segment (or (fixup-offset fixup) 0)))


;;;; the effective-address (ea) structure

(defun reg-tn-encoding (tn)
  (declare (type tn tn))
  ;; ea only has space for three bits of register number: regs r8
  ;; and up are selected by a REX prefix byte which caller is responsible
  ;; for having emitted where necessary already
  (ecase (sb-name (sc-sb (tn-sc tn)))
    (registers
     (let ((offset (mod (tn-offset tn) 16)))
       (logior (ash (logand offset 1) 2)
               (ash offset -1))))
    (float-registers
     (mod (tn-offset tn) 8))))

(defstruct (ea (:constructor make-ea (size &key base index scale disp))
               (:copier nil))
  ;; note that we can represent an EA with a QWORD size, but EMIT-EA
  ;; can't actually emit it on its own: caller also needs to emit REX
  ;; prefix
  (size nil :type (member :byte :word :dword :qword))
  (base nil :type (or tn null))
  (index nil :type (or tn null))
  (scale 1 :type (member 1 2 4 8))
  (disp 0 :type (or (unsigned-byte 32) (signed-byte 32) fixup)))
(def!method print-object ((ea ea) stream)
  (cond ((or *print-escape* *print-readably*)
         (print-unreadable-object (ea stream :type t)
           (format stream
                   "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
                   (ea-size ea)
                   (ea-base ea)
                   (ea-index ea)
                   (let ((scale (ea-scale ea)))
                     (if (= scale 1) nil scale))
                   (ea-disp ea))))
        (t
         (format stream "~A PTR [" (symbol-name (ea-size ea)))
         (when (ea-base ea)
           (write-string (sb!c::location-print-name (ea-base ea)) stream)
           (when (ea-index ea)
             (write-string "+" stream)))
         (when (ea-index ea)
           (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)
           (null)
           (integer
            (format stream "~@D" (ea-disp ea)))
           (t
            (format stream "+~A" (ea-disp ea))))
         (write-char #\] stream))))

(defun emit-constant-tn-rip (segment constant-tn reg)
  ;; AMD64 doesn't currently have a code object register to use as a
  ;; base register for constant access. Instead we use RIP-relative
  ;; addressing. The offset from the SIMPLE-FUN-HEADER to the instruction
  ;; is passed to the backpatch callback. In addition we need the offset
  ;; from the start of the function header to the slot in the CODE-HEADER
  ;; that stores the constant. Since we don't know where the code header
  ;; starts, instead count backwards from the function header.
  (let* ((2comp (component-info *component-being-compiled*))
         (constants (ir2-component-constants 2comp))
         (len (length constants))
         ;; Both CODE-HEADER and SIMPLE-FUN-HEADER are 16-byte aligned.
         ;; If there are an even amount of constants, there will be
         ;; an extra qword of padding before the function header, which
         ;; needs to be adjusted for. XXX: This will break if new slots
         ;; are added to the code header.
         (offset (* (- (+ len (if (evenp len)
                                  1
                                  2))
                       (tn-offset constant-tn))
                    n-word-bytes)))
    ;; RIP-relative addressing
    (emit-mod-reg-r/m-byte segment #b00 reg #b101)
    (emit-back-patch segment
                     4
                     (lambda (segment posn)
                       ;; The addressing is relative to end of instruction,
                       ;; i.e. the end of this dword. Hence the + 4.
                       (emit-signed-dword segment
                                          (+ 4 (- (+ offset posn)))))))
  (values))

(defun emit-label-rip (segment fixup reg)
  (let ((label (fixup-offset fixup)))
    ;; RIP-relative addressing
    (emit-mod-reg-r/m-byte segment #b00 reg #b101)
    (emit-back-patch segment
                     4
                     (lambda (segment posn)
                       (emit-signed-dword segment (- (label-position label)
                                                     (+ posn 4))))))
  (values))

(defun emit-ea (segment thing reg &optional allow-constants)
  (etypecase thing
    (tn
     ;; this would be eleganter if we had a function that would create
     ;; an ea given a tn
     (ecase (sb-name (sc-sb (tn-sc thing)))
       ((registers float-registers)
        (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
       (stack
        ;; Convert stack tns into an index off RBP.
        (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))
                (t
                 (emit-mod-reg-r/m-byte segment #b10 reg #b101)
                 (emit-signed-dword segment disp)))))
       (constant
        (unless allow-constants
          ;; Why?
          (error
           "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
        (emit-constant-tn-rip segment thing reg))))
    (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)))))
       (when (and (= mod 0) (= r/m #b101))
         ;; this is rip-relative in amd64, so we'll use a sib instead
         (setf r/m #b100 scale 1))
       (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))))