insts.lisp

开源跨平台Lisp编译器

;;; the instruction set definition for MIPS

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

(setf *assem-scheduler-p* t)
(setf *assem-max-locations* 68)

;;;; 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))
  (tn-offset tn))

;;;(sb!disassem:set-disassem-params :instruction-alignment 32)

(defvar *disassem-use-lisp-reg-names* t)

(!def-vm-support-routine location-number (loc)
  (etypecase loc
    (null)
    (number)
    (label)
    (fixup)
    (tn
     (ecase (sb-name (sc-sb (tn-sc loc)))
       (immediate-constant
        ;; Can happen if $ZERO or $NULL are passed in.
        nil)
       (registers
        (unless (zerop (tn-offset loc))
          (tn-offset loc)))
       (float-registers
        (+ (tn-offset loc) 32))))
    (symbol
     (ecase loc
       (:memory 0)
       (:hi-reg 64)
       (:low-reg 65)
       (:float-status 66)
       (:ctrl-stat-reg 67)))))

(defparameter reg-symbols
  (map 'vector
       #'(lambda (name)
           (cond ((null name) nil)
                 (t (make-symbol (concatenate 'string "$" name)))))
       *register-names*))

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

(defparameter float-reg-symbols
  #.(coerce
     (loop for n from 0 to 31 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))))

(sb!disassem:define-arg-type control-reg
  :printer "(CR:#x~X)")

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

(deftype float-format ()
  '(member :s :single :d :double :w :word))

(defun float-format-value (format)
  (ecase format
    ((:s :single) 0)
    ((:d :double) 1)
    ((:w :word) 4)))

(sb!disassem:define-arg-type float-format
  :printer #'(lambda (value stream dstate)
               (declare (ignore dstate)
                        (stream stream)
                        (fixnum value))
               (princ (case value
                        (0 's)
                        (1 'd)
                        (4 'w)
                        (t '?))
                      stream)))

(defconstant-eqx compare-kinds
  '(:f :un :eq :ueq :olt :ult :ole :ule :sf :ngle :seq :ngl :lt :nge :le :ngt)
  #'equalp)

(defconstant-eqx compare-kinds-vec
  (apply #'vector compare-kinds)
  #'equalp)

(deftype compare-kind ()
  `(member ,@compare-kinds))

(defun compare-kind (kind)
  (or (position kind compare-kinds)
      (error "Unknown floating point compare kind: ~S~%Must be one of: ~S"
             kind
             compare-kinds)))

(sb!disassem:define-arg-type compare-kind
  :printer compare-kinds-vec)

(defconstant-eqx float-operations '(+ - * /) #'equalp)

(deftype float-operation ()
  `(member ,@float-operations))

(defconstant-eqx float-operation-names
  ;; this gets used for output only
  #(add sub mul div)
  #'equalp)

(defun float-operation (op)
  (or (position op float-operations)
      (error "Unknown floating point operation: ~S~%Must be one of: ~S"
             op
             float-operations)))

(sb!disassem:define-arg-type float-operation
  :printer float-operation-names)



;;;; Constants used by instruction emitters.

(def!constant special-op #b000000)
(def!constant bcond-op #b000001)
(def!constant cop0-op #b010000)
(def!constant cop1-op #b010001)
(def!constant cop2-op #b010010)
(def!constant cop3-op #b010011)



;;;; dissassem:define-instruction-formats

(defconstant-eqx immed-printer
  '(:name :tab rt (:unless (:same-as rt) ", " rs) ", " immediate)
  #'equalp)

;;; for things that use rt=0 as a nop
(defconstant-eqx immed-zero-printer
  '(:name :tab rt (:unless (:constant 0) ", " rs) ", " immediate)
  #'equalp)

(sb!disassem:define-instruction-format
    (immediate 32 :default-printer immed-printer)
  (op :field (byte 6 26))
  (rs :field (byte 5 21) :type 'reg)
  (rt :field (byte 5 16) :type 'reg)
  (immediate :field (byte 16 0) :sign-extend t))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter jump-printer
    #'(lambda (value stream dstate)
        (let ((addr (ash value 2)))
          (sb!disassem:maybe-note-assembler-routine addr t dstate)
          (write addr :base 16 :radix t :stream stream)))))

(sb!disassem:define-instruction-format
    (jump 32 :default-printer '(:name :tab target))
  (op :field (byte 6 26))
  (target :field (byte 26 0) :printer jump-printer))

(defconstant-eqx reg-printer
  '(:name :tab rd (:unless (:same-as rd) ", " rs) ", " rt)
  #'equalp)

(sb!disassem:define-instruction-format
    (register 32 :default-printer reg-printer)
  (op :field (byte 6 26))
  (rs :field (byte 5 21) :type 'reg)
  (rt :field (byte 5 16) :type 'reg)
  (rd :field (byte 5 11) :type 'reg)
  (shamt :field (byte 5 6) :value 0)
  (funct :field (byte 6 0)))

(sb!disassem:define-instruction-format
    (break 32 :default-printer
           '(:name :tab code (:unless (:constant 0) ", " subcode)))
  (op :field (byte 6 26) :value special-op)
  (code :field (byte 10 16))
  (subcode :field (byte 10 6))
  (funct :field (byte 6 0) :value #b001101))

(sb!disassem:define-instruction-format
    (coproc-branch 32 :default-printer '(:name :tab offset))
  (op :field (byte 6 26))
  (funct :field (byte 10 16))
  (offset :field (byte 16 0)))

(defconstant-eqx float-fmt-printer
  '((:unless :constant funct)
    (:choose (:unless :constant sub-funct) nil)
    "." format)
  #'equalp)

(defconstant-eqx float-printer
  `(:name ,@float-fmt-printer
          :tab
          fd
          (:unless (:same-as fd) ", " fs)
          ", " ft)
  #'equalp)

(sb!disassem:define-instruction-format
    (float 32 :default-printer float-printer)
  (op :field (byte 6 26) :value cop1-op)
  (filler :field (byte 1 25) :value 1)
  (format :field (byte 4 21) :type 'float-format)
  (ft :field (byte 5 16) :value 0)
  (fs :field (byte 5 11) :type 'fp-reg)
  (fd :field (byte 5 6) :type 'fp-reg)
  (funct :field (byte 6 0)))

(sb!disassem:define-instruction-format
    (float-aux 32 :default-printer float-printer)
  (op :field (byte 6 26) :value cop1-op)
  (filler-1 :field (byte 1 25) :value 1)
  (format :field (byte 4 21) :type 'float-format)
  (ft :field (byte 5 16) :type 'fp-reg)
  (fs :field (byte 5 11) :type 'fp-reg)
  (fd :field (byte 5 6) :type 'fp-reg)
  (funct :field (byte 2 4))
  (sub-funct :field (byte 4 0)))

(sb!disassem:define-instruction-format
    (float-op 32
              :include 'float
              :default-printer
                '('f funct "." format
                  :tab
                  fd
                  (:unless (:same-as fd) ", " fs)
                  ", " ft))
  (funct        :field (byte 2 0) :type 'float-operation)
  (funct-filler :field (byte 4 2) :value 0)
  (ft           :value nil :type 'fp-reg))


;;;; Primitive emitters.

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

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

(define-bitfield-emitter emit-immediate-inst 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0))

(define-bitfield-emitter emit-jump-inst 32
  (byte 6 26) (byte 26 0))

(define-bitfield-emitter emit-register-inst 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 5 6) (byte 6 0))

(define-bitfield-emitter emit-break-inst 32
  (byte 6 26) (byte 10 16) (byte 10 6) (byte 6 0))

(define-bitfield-emitter emit-float-inst 32
  (byte 6 26) (byte 1 25) (byte 4 21) (byte 5 16)
  (byte 5 11) (byte 5 6) (byte 6 0))



;;;; Math instructions.

(defun emit-math-inst (segment dst src1 src2 reg-opcode immed-opcode
                               &optional allow-fixups)
  (unless src2
    (setf src2 src1)
    (setf src1 dst))
  (etypecase src2
    (tn
     (emit-register-inst segment special-op (reg-tn-encoding src1)
                         (reg-tn-encoding src2) (reg-tn-encoding dst)
                         0 reg-opcode))
    (integer
     (emit-immediate-inst segment immed-opcode (reg-tn-encoding src1)
                          (reg-tn-encoding dst) src2))
    (fixup
     (unless allow-fixups
       (error "Fixups aren't allowed."))
     (note-fixup segment :addi src2)
     (emit-immediate-inst segment immed-opcode (reg-tn-encoding src1)
                          (reg-tn-encoding dst) 0))))

(define-instruction add (segment dst src1 &optional src2)
  (:declare (type tn dst)
            (type (or tn (signed-byte 16) null) src1 src2))
  (:printer register ((op special-op) (funct #b100000)))
  (:printer immediate ((op #b001000)))
  (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
  (:delay 0)
  (:emitter
   (emit-math-inst segment dst src1 src2 #b100000 #b001000)))

(define-instruction addu (segment dst src1 &optional src2)
  (:declare (type tn dst)
            (type (or tn (signed-byte 16) fixup null) src1 src2))
  (:printer register ((op special-op) (funct #b100001)))
  (:printer immediate ((op #b001001)))
  (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
  (:delay 0)
  (:emitter
   (emit-math-inst segment dst src1 src2 #b100001 #b001001 t)))