insts.lisp

开源跨平台Lisp编译器

;;;; that part of the description of the x86 instruction set (for
;;;; 80386 and above) which can live on the cross-compilation host

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!VM")
;;; FIXME: SB!DISASSEM: prefixes are used so widely in this file that
;;; I wonder whether the separation of the disassembler from the
;;; virtual machine is valid or adds value.

;;; Note: In CMU CL, this used to be a call to SET-DISASSEM-PARAMS.
(setf sb!disassem:*disassem-inst-alignment-bytes* 1)

(deftype reg () '(unsigned-byte 3))

(def!constant +default-operand-size+ :dword)

(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

(defun offset-next (value dstate)
  (declare (type integer value)
           (type sb!disassem:disassem-state dstate))
  (+ (sb!disassem:dstate-next-addr dstate) value))

(defparameter *default-address-size*
  ;; Actually, :DWORD is the only one really supported.
  :dword)

(defparameter *byte-reg-names*
  #(al cl dl bl ah ch dh bh))
(defparameter *word-reg-names*
  #(ax cx dx bx sp bp si di))
(defparameter *dword-reg-names*
  #(eax ecx edx ebx esp ebp esi edi))

(defun print-reg-with-width (value width stream dstate)
  (declare (ignore dstate))
  (princ (aref (ecase width
                 (:byte *byte-reg-names*)
                 (:word *word-reg-names*)
                 (:dword *dword-reg-names*))
               value)
         stream)
  ;; XXX plus should do some source-var notes
  )

(defun print-reg (value stream dstate)
  (declare (type reg value)
           (type stream stream)
           (type sb!disassem:disassem-state dstate))
  (print-reg-with-width value
                        (sb!disassem:dstate-get-prop dstate 'width)
                        stream
                        dstate))

(defun print-word-reg (value stream dstate)
  (declare (type reg value)
           (type stream stream)
           (type sb!disassem:disassem-state dstate))
  (print-reg-with-width value
                        (or (sb!disassem:dstate-get-prop dstate 'word-width)
                            +default-operand-size+)
                        stream
                        dstate))

(defun print-byte-reg (value stream dstate)
  (declare (type reg value)
           (type stream stream)
           (type sb!disassem:disassem-state dstate))
  (print-reg-with-width value :byte stream dstate))

(defun print-addr-reg (value stream dstate)
  (declare (type reg value)
           (type stream stream)
           (type sb!disassem:disassem-state dstate))
  (print-reg-with-width value *default-address-size* stream dstate))

(defun print-reg/mem (value stream dstate)
  (declare (type (or list reg) value)
           (type stream stream)
           (type sb!disassem:disassem-state dstate))
  (if (typep value 'reg)
      (print-reg value stream dstate)
      (print-mem-access value stream nil dstate)))

;; Same as print-reg/mem, but prints an explicit size indicator for
;; memory references.
(defun print-sized-reg/mem (value stream dstate)
  (declare (type (or list reg) value)
           (type stream stream)
           (type sb!disassem:disassem-state dstate))
  (if (typep value 'reg)
      (print-reg value stream dstate)
      (print-mem-access value stream t dstate)))

(defun print-byte-reg/mem (value stream dstate)
  (declare (type (or list reg) value)
           (type stream stream)
           (type sb!disassem:disassem-state dstate))
  (if (typep value 'reg)
      (print-byte-reg value stream dstate)
      (print-mem-access value stream t dstate)))

(defun print-word-reg/mem (value stream dstate)
  (declare (type (or list reg) value)
           (type stream stream)
           (type sb!disassem:disassem-state dstate))
  (if (typep value 'reg)
      (print-word-reg value stream dstate)
      (print-mem-access value stream nil dstate)))

(defun print-label (value stream dstate)
  (declare (ignore dstate))
  (sb!disassem:princ16 value stream))

;;; Returns either an integer, meaning a register, or a list of
;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
;;; may be missing or nil to indicate that it's not used or has the
;;; obvious default value (e.g., 1 for the index-scale).
(defun prefilter-reg/mem (value dstate)
  (declare (type list value)
           (type sb!disassem:disassem-state dstate))
  (let ((mod (car value))
        (r/m (cadr value)))
    (declare (type (unsigned-byte 2) mod)
             (type (unsigned-byte 3) r/m))
    (cond ((= mod #b11)
           ;; registers
           r/m)
          ((= r/m #b100)
           ;; sib byte
           (let ((sib (sb!disassem:read-suffix 8 dstate)))
             (declare (type (unsigned-byte 8) sib))
             (let ((base-reg (ldb (byte 3 0) sib))
                   (index-reg (ldb (byte 3 3) sib))
                   (index-scale (ldb (byte 2 6) sib)))
               (declare (type (unsigned-byte 3) base-reg index-reg)
                        (type (unsigned-byte 2) index-scale))
               (let* ((offset
                       (case mod
                         (#b00
                          (if (= base-reg #b101)
                              (sb!disassem:read-signed-suffix 32 dstate)
                              nil))
                         (#b01
                          (sb!disassem:read-signed-suffix 8 dstate))
                         (#b10
                          (sb!disassem:read-signed-suffix 32 dstate)))))
                 (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
                       offset
                       (if (= index-reg #b100) nil index-reg)
                       (ash 1 index-scale))))))
          ((and (= mod #b00) (= r/m #b101))
           (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
          ((= mod #b00)
           (list r/m))
          ((= mod #b01)
           (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
          (t                            ; (= mod #b10)
           (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))


;;; This is a sort of bogus prefilter that just stores the info globally for
;;; other people to use; it probably never gets printed.
(defun prefilter-width (value dstate)
  (setf (sb!disassem:dstate-get-prop dstate 'width)
        (if (zerop value)
            :byte
            (let ((word-width
                   ;; set by a prefix instruction
                   (or (sb!disassem:dstate-get-prop dstate 'word-width)
                       +default-operand-size+)))
              (when (not (eql word-width +default-operand-size+))
                ;; Reset it.
                (setf (sb!disassem:dstate-get-prop dstate 'word-width)
                      +default-operand-size+))
              word-width))))

(defun read-address (value dstate)
  (declare (ignore value))              ; always nil anyway
  (sb!disassem:read-suffix (width-bits *default-address-size*) dstate))

(defun width-bits (width)
  (ecase width
    (:byte 8)
    (:word 16)
    (:dword 32)
    (:float 32)
    (:double 64)))

) ; EVAL-WHEN

;;;; disassembler argument types

(sb!disassem:define-arg-type displacement
  :sign-extend t
  :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-arg-type accum
  :printer (lambda (value stream dstate)
             (declare (ignore value)
                      (type stream stream)
                      (type sb!disassem:disassem-state dstate))
             (print-reg 0 stream dstate)))

(sb!disassem:define-arg-type word-accum
  :printer (lambda (value stream dstate)
             (declare (ignore value)
                      (type stream stream)
                      (type sb!disassem:disassem-state dstate))
             (print-word-reg 0 stream dstate)))

(sb!disassem:define-arg-type reg
  :printer #'print-reg)

(sb!disassem:define-arg-type addr-reg
  :printer #'print-addr-reg)

(sb!disassem:define-arg-type word-reg
  :printer #'print-word-reg)

(sb!disassem:define-arg-type imm-addr
  :prefilter #'read-address
  :printer #'print-label)

(sb!disassem:define-arg-type imm-data
  :prefilter (lambda (value dstate)
               (declare (ignore value)) ; always nil anyway
               (sb!disassem:read-suffix
                (width-bits (sb!disassem:dstate-get-prop dstate 'width))
                dstate)))

(sb!disassem:define-arg-type signed-imm-data
  :prefilter (lambda (value dstate)
               (declare (ignore value)) ; always nil anyway
               (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
                 (sb!disassem:read-signed-suffix (width-bits width) dstate))))

(sb!disassem:define-arg-type signed-imm-byte
  :prefilter (lambda (value dstate)
               (declare (ignore value)) ; always nil anyway
               (sb!disassem:read-signed-suffix 8 dstate)))

(sb!disassem:define-arg-type signed-imm-dword
  :prefilter (lambda (value dstate)
               (declare (ignore value)) ; always nil anyway
               (sb!disassem:read-signed-suffix 32 dstate)))

(sb!disassem:define-arg-type imm-word
  :prefilter (lambda (value dstate)
               (declare (ignore value)) ; always nil anyway
               (let ((width
                      (or (sb!disassem:dstate-get-prop dstate 'word-width)
                          +default-operand-size+)))
                 (sb!disassem:read-suffix (width-bits width) dstate))))

(sb!disassem:define-arg-type signed-imm-word
  :prefilter (lambda (value dstate)
               (declare (ignore value)) ; always nil anyway
               (let ((width
                      (or (sb!disassem:dstate-get-prop dstate 'word-width)
                          +default-operand-size+)))
                 (sb!disassem:read-signed-suffix (width-bits width) dstate))))

;;; needed for the ret imm16 instruction
(sb!disassem:define-arg-type imm-word-16
  :prefilter (lambda (value dstate)
               (declare (ignore value)) ; always nil anyway
               (sb!disassem:read-suffix 16 dstate)))

(sb!disassem:define-arg-type reg/mem
  :prefilter #'prefilter-reg/mem
  :printer #'print-reg/mem)
(sb!disassem:define-arg-type sized-reg/mem
  ;; Same as reg/mem, but prints an explicit size indicator for
  ;; memory references.
  :prefilter #'prefilter-reg/mem
  :printer #'print-sized-reg/mem)
(sb!disassem:define-arg-type byte-reg/mem
  :prefilter #'prefilter-reg/mem
  :printer #'print-byte-reg/mem)
(sb!disassem:define-arg-type word-reg/mem
  :prefilter #'prefilter-reg/mem
  :printer #'print-word-reg/mem)

;;; added by jrd
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(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-arg-type fp-reg
                             :prefilter #'prefilter-fp-reg
                             :printer #'print-fp-reg)

(sb!disassem:define-arg-type width
  :prefilter #'prefilter-width
  :printer (lambda (value stream dstate)
             (if;; (zerop value)
                 (or (null value)
                     (and (numberp value) (zerop value))) ; zzz jrd
                 (princ 'b stream)
                 (let ((word-width
                        ;; set by a prefix instruction
                        (or (sb!disassem:dstate-get-prop dstate 'word-width)
                            +default-operand-size+)))
                   (princ (schar (symbol-name word-width) 0) stream)))))

(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *conditions*
  '((:o . 0)
    (:no . 1)
    (:b . 2) (:nae . 2) (:c . 2)
    (:nb . 3) (:ae . 3) (:nc . 3)
    (:eq . 4) (:e . 4) (:z . 4)
    (:ne . 5) (:nz . 5)
    (:be . 6) (:na . 6)
    (:nbe . 7) (:a . 7)
    (:s . 8)
    (:ns . 9)
    (:p . 10) (:pe . 10)
    (:np . 11) (:po . 11)
    (:l . 12) (:nge . 12)
    (: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*)
      (when (null (aref vec (cdr cond)))
        (setf (aref vec (cdr cond)) (car cond))))
    vec))
) ; EVAL-WHEN

;;; Set assembler parameters. (In CMU CL, this was done with
;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf sb!assem:*assem-scheduler-p* nil))

(sb!disassem:define-arg-type condition-code
  :printer *condition-name-vec*)

(defun conditional-opcode (condition)
  (cdr (assoc condition *conditions* :test #'eq)))

;;;; disassembler instruction formats