insts.lisp

开源跨平台Lisp编译器

;;;; the instruction set definition for the Sparc

;;;; 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")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf sb!assem:*assem-scheduler-p* t)
  (setf sb!assem:*assem-max-locations* 100))

;;; Constants, types, conversion functions, some disassembler stuff.
(defun reg-tn-encoding (tn)
  (declare (type tn tn))
  (sc-case tn
    (zero zero-offset)
    (null null-offset)
    (t
     (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
         (tn-offset tn)
         (error "~S isn't a register." tn)))))

(defun fp-reg-tn-encoding (tn)
  (declare (type tn tn))
  (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
    (error "~S isn't a floating-point register." tn))
  (let ((offset (tn-offset tn)))
    (cond ((> offset 31)
           (aver (member :sparc-v9 *backend-subfeatures*))
           ;; No single register encoding greater than reg 31.
           (aver (zerop (mod offset 2)))
           ;; Upper bit of the register number is encoded in the low bit.
           (1+ (- offset 32)))
          (t
           (tn-offset tn)))))

;;;(sb!disassem:set-disassem-params :instruction-alignment 32
;;;                              :opcode-column-width 11)

(defvar *disassem-use-lisp-reg-names* t
  #!+sb-doc
  "If non-NIL, print registers using the Lisp register names.
Otherwise, use the Sparc register names")

(!def-vm-support-routine location-number (loc)
  (etypecase loc
    (null)
    (number)
    (fixup)
    (tn
     (ecase (sb-name (sc-sb (tn-sc loc)))
       (registers
        (unless (zerop (tn-offset loc))
          (tn-offset loc)))
       (float-registers
        (sc-case loc
          (single-reg
           (+ (tn-offset loc) 32))
          (double-reg
           (let ((offset (tn-offset loc)))
             (aver (zerop (mod offset 2)))
             (values (+ offset 32) 2)))
          #!+long-float
          (long-reg
           (let ((offset (tn-offset loc)))
             (aver (zerop (mod offset 4)))
             (values (+ offset 32) 4)))))
       (control-registers
        96)
       (immediate-constant
        nil)))
    (symbol
     (ecase loc
       (:memory 0)
       (:psr 97)
       (:fsr 98)
       (:y 99)))))

;;; symbols used for disassembly printing
(defparameter reg-symbols
  (map 'vector
       (lambda (name)
           (cond ((null name) nil)
                 (t (make-symbol (concatenate 'string "%" name)))))
       *register-names*)
  #!+sb-doc "The Lisp names for the Sparc integer registers")

(defparameter sparc-reg-symbols
  #("%G0" "%G1" "%G2" "%G3" "%G4" "%G5" NIL NIL
    "%O0" "%O1" "%O2" "%O3" "%O4" "%O5" "%O6" "%O7"
    "%L0" "%L1" "%L2" "%L3" "%L4" "%L5" "%L6" "%L7"
    "%I0" "%I1" "%I2" "%I3" "%I4" "%I5" NIL "%I7")
  #!+sb-doc "The standard names for the Sparc integer registers")

(defun get-reg-name (index)
  (if *disassem-use-lisp-reg-names*
      (aref reg-symbols index)
      (aref sparc-reg-symbols index)))

(defvar *note-sethi-inst* nil
  "An alist for the disassembler indicating the target register and
value used in a SETHI instruction.  This is used to make annotations
about function addresses and register values.")

(defvar *pseudo-atomic-set* nil)

(defun sign-extend-immed-value (val)
  ;; val is a 13-bit signed number.  Extend the sign appropriately.
  (if (logbitp 12 val)
      (- val (ash 1 13))
      val))

;; Look at the current instruction and see if we can't add some notes
;; about what's happening.

(defun maybe-add-notes (reg dstate)
  (let* ((word (sb!disassem::sap-ref-int (sb!disassem::dstate-segment-sap dstate)
                                      (sb!disassem::dstate-cur-offs dstate)
                                      n-word-bytes
                                      (sb!disassem::dstate-byte-order dstate)))
         (format (ldb (byte 2 30) word))
         (op3 (ldb (byte 6 19) word))
         (rs1 (ldb (byte 5 14) word))
         (rd (ldb (byte 5 25) word))
         (immed-p (not (zerop (ldb (byte 1 13) word))))
         (immed-val (sign-extend-immed-value (ldb (byte 13 0) word))))
    (declare (ignore immed-p))
    ;; Only the value of format and rd are guaranteed to be correct
    ;; because the disassembler is trying to print out the value of a
    ;; register.  The other values may not be right.
    (case format
      (2
       (case op3
         (#b000000
          (when (= reg rs1)
            (handle-add-inst rs1 immed-val rd dstate)))
         (#b111000
          (when (= reg rs1)
            (handle-jmpl-inst rs1 immed-val rd dstate)))
         (#b010001
          (when (= reg rs1)
            (handle-andcc-inst rs1 immed-val rd dstate)))))
      (3
       (case op3
         ((#b000000 #b000100)
          (when (= reg rs1)
            (handle-ld/st-inst rs1 immed-val rd dstate))))))
    ;; If this is not a SETHI instruction, and RD is the same as some
    ;; register used by SETHI, we delete the entry.  (In case we have
    ;; a SETHI without any additional instruction because the low bits
    ;; were zero.)
    (unless (and (zerop format) (= #b100 (ldb (byte 3 22) word)))
      (let ((sethi (assoc rd *note-sethi-inst*)))
        (when sethi
          (setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))))))

(defun handle-add-inst (rs1 immed-val rd dstate)
  (let* ((sethi (assoc rs1 *note-sethi-inst*)))
    (cond
      (sethi
       ;; RS1 was used in a SETHI instruction.  Assume that
       ;; this is the offset part of the SETHI instruction for
       ;; a full 32-bit address of something.  Make a note
       ;; about this usage as a Lisp assembly routine or
       ;; foreign routine, if possible.  If not, just note the
       ;; final value.
       (let ((addr (+ immed-val (ash (cdr sethi) 10))))
         (or (sb!disassem::note-code-constant-absolute addr dstate)
             (sb!disassem:maybe-note-assembler-routine addr t dstate)
             (sb!disassem:note (format nil "~A = #x~8,'0X"
                                     (get-reg-name rd) addr)
                             dstate)))
       (setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))
      ((= rs1 null-offset)
       ;; We have an ADD %NULL, <n>, RD instruction.  This is a
       ;; reference to a static symbol.
       (sb!disassem:maybe-note-nil-indexed-object immed-val
                                               dstate))
      ((= rs1 alloc-offset)
       ;; ADD %ALLOC, n.  This must be some allocation or
       ;; pseudo-atomic stuff
       (cond ((and (= immed-val 4) (= rd alloc-offset)
                   (not *pseudo-atomic-set*))
              ;; "ADD 4, %ALLOC" sets the flag
              (sb!disassem::note "Set pseudo-atomic flag" dstate)
              (setf *pseudo-atomic-set* t))
             ((= rd alloc-offset)
              ;; "ADD n, %ALLOC" is reseting the flag, with extra
              ;; allocation.
              (sb!disassem:note
               (format nil "Reset pseudo-atomic, allocated ~D bytes"
                       (+ immed-val 4)) dstate)
              (setf *pseudo-atomic-set* nil))))
      #+nil ((and (= rs1 zero-offset) *pseudo-atomic-set*)
       ;; "ADD %ZERO, num, RD" inside a pseudo-atomic is very
       ;; likely loading up a header word.  Make a note to that
       ;; effect.
       (let ((type (second (assoc (logand immed-val #xff) header-word-type-alist)))
             (size (ldb (byte 24 8) immed-val)))
         (when type
           (sb!disassem:note (format nil "Header word ~A, size ~D?" type size)
                          dstate)))))))

(defun handle-jmpl-inst (rs1 immed-val rd dstate)
  (declare (ignore rd))
  (let* ((sethi (assoc rs1 *note-sethi-inst*)))
    (when sethi
      ;; RS1 was used in a SETHI instruction.  Assume that
      ;; this is the offset part of the SETHI instruction for
      ;; a full 32-bit address of something.  Make a note
      ;; about this usage as a Lisp assembly routine or
      ;; foreign routine, if possible.  If not, just note the
      ;; final value.
      (let ((addr (+ immed-val (ash (cdr sethi) 10))))
        (sb!disassem:maybe-note-assembler-routine addr t dstate)
        (setf *note-sethi-inst* (delete sethi *note-sethi-inst*))))))

(defun handle-ld/st-inst (rs1 immed-val rd dstate)
  (declare (ignore rd))
  ;; Got an LDUW/LD or STW instruction, with immediate offset.
  (case rs1
    (29
     ;; A reference to a code constant (reg = %CODE)
     (sb!disassem:note-code-constant immed-val dstate))
    (2
     ;; A reference to a static symbol or static function (reg =
     ;; %NULL)
     (or (sb!disassem:maybe-note-nil-indexed-symbol-slot-ref immed-val
                                                      dstate)
         #+nil (sb!disassem::maybe-note-static-function immed-val dstate)))
    (t
     (let ((sethi (assoc rs1 *note-sethi-inst*)))
       (when sethi
         (let ((addr (+ immed-val (ash (cdr sethi) 10))))
           (sb!disassem:maybe-note-assembler-routine addr nil dstate)
           (setf *note-sethi-inst* (delete sethi *note-sethi-inst*))))))))

(defun handle-andcc-inst (rs1 immed-val rd dstate)
  ;; ANDCC %ALLOC, 3, %ZERO instruction
  (when (and (= rs1 alloc-offset) (= rd zero-offset) (= immed-val 3))
    (sb!disassem:note "pseudo-atomic interrupted?" dstate)))

(sb!disassem:define-arg-type reg
  :printer (lambda (value stream dstate)
               (declare (stream stream) (fixnum value))
               (let ((regname (get-reg-name value)))
                 (princ regname stream)
                 (sb!disassem:maybe-note-associated-storage-ref value
                                                                'registers
                                                                regname
                                                                dstate)
                 (maybe-add-notes value dstate))))

(defparameter float-reg-symbols
  #.(coerce
     (loop for n from 0 to 63 collect (make-symbol (format nil "%F~d" n)))
     'vector))

(sb!disassem:define-arg-type fp-reg
  :printer (lambda (value stream dstate)
               (declare (stream stream) (fixnum value))
               (let ((regname (aref float-reg-symbols value)))
                 (princ regname stream)
                 (sb!disassem:maybe-note-associated-storage-ref
                  value
                  'float-registers
                  regname
                  dstate))))

;;; The extended 6 bit floating point register encoding for the double
;;; and long instructions of the sparc v9.
(sb!disassem:define-arg-type fp-ext-reg
  :printer (lambda (value stream dstate)
               (declare (stream stream) (fixnum value))
               (let* (;; Decode the register number.
                      (value (if (oddp value) (+ value 31) value))
                      (regname (aref float-reg-symbols value)))
                 (princ regname stream)
                 (sb!disassem:maybe-note-associated-storage-ref
                  value
                  'float-registers
                  regname
                  dstate))))

(sb!disassem:define-arg-type relative-label
  :sign-extend t
  :use-label (lambda (value dstate)
               (declare (type (signed-byte 22) value)
                        (type sb!disassem:disassem-state dstate))
               (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))

(defconstant-eqx branch-conditions
  '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc)
  #'equalp)

;;; Note that these aren't the standard names for branch-conditions, I
;;; think they're a bit more readable (e.g., "eq" instead of "e").
;;; You could just put a vector of the normal ones here too.

(sb!disassem:define-arg-type branch-condition
  :printer (coerce branch-conditions 'vector))

(deftype branch-condition ()
  `(member ,@branch-conditions))

(defun branch-condition (condition)
  (or (position condition branch-conditions)
      (error "Unknown branch condition: ~S~%Must be one of: ~S"
             condition branch-conditions)))

(def!constant branch-cond-true
  #b1000)

(defconstant-eqx branch-fp-conditions
  '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o)
  #'equalp)

(sb!disassem:define-arg-type branch-fp-condition
  :printer (coerce branch-fp-conditions 'vector))

(sb!disassem:define-arg-type call-fixup :use-label t)

(deftype fp-branch-condition ()
  `(member ,@branch-fp-conditions))

(defun fp-branch-condition (condition)
  (or (position condition branch-fp-conditions)
      (error "Unknown fp-branch condition: ~S~%Must be one of: ~S"
             condition branch-fp-conditions)))


;;;; dissassem:define-instruction-formats

(sb!disassem:define-instruction-format
    (format-1 32 :default-printer '(:name :tab disp))
  (op   :field (byte 2 30) :value 1)
  (disp :field (byte 30 0)))