insts.lisp

开源跨平台Lisp编译器

(define-instruction sub (segment dst src1 &optional src2)
  (:declare
   (type tn dst)
   (type (or tn (integer #.(- 1 (ash 1 15)) #.(ash 1 15)) null) src1 src2))
  (:printer register ((op special-op) (funct #b100010)))
  (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
  (:delay 0)
  (:emitter
   (unless src2
     (setf src2 src1)
     (setf src1 dst))
   (emit-math-inst segment dst src1
                   (if (integerp src2) (- src2) src2)
                   #b100010 #b001000)))

(define-instruction subu (segment dst src1 &optional src2)
  (:declare
   (type tn dst)
   (type
    (or tn (integer #.(- 1 (ash 1 15)) #.(ash 1 15)) fixup null) src1 src2))
  (:printer register ((op special-op) (funct #b100011)))
  (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
  (:delay 0)
  (:emitter
   (unless src2
     (setf src2 src1)
     (setf src1 dst))
   (emit-math-inst segment dst src1
                   (if (integerp src2) (- src2) src2)
                   #b100011 #b001001 t)))

(define-instruction and (segment dst src1 &optional src2)
  (:declare (type tn dst)
            (type (or tn (unsigned-byte 16) null) src1 src2))
  (:printer register ((op special-op) (funct #b100100)))
  (:printer immediate ((op #b001100) (immediate nil :sign-extend nil)))
  (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
  (:delay 0)
  (:emitter
   (emit-math-inst segment dst src1 src2 #b100100 #b001100)))

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

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

(define-instruction nor (segment dst src1 &optional src2)
  (:declare (type tn dst src1) (type (or tn null) src2))
  (:printer register ((op special-op) (funct #b100111)))
  (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
  (:delay 0)
  (:emitter
   (emit-math-inst segment dst src1 src2 #b100111 #b000000)))

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

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

(defconstant-eqx divmul-printer '(:name :tab rs ", " rt) #'equalp)

(define-instruction div (segment src1 src2)
  (:declare (type tn src1 src2))
  (:printer register ((op special-op) (rd 0) (funct #b011010)) divmul-printer)
  (:dependencies (reads src1) (reads src2) (writes :hi-reg) (writes :low-reg))
  (:delay 1)
  (:emitter
   (emit-register-inst segment special-op (reg-tn-encoding src1)
                       (reg-tn-encoding src2) 0 0 #b011010)))

(define-instruction divu (segment src1 src2)
  (:declare (type tn src1 src2))
  (:printer register ((op special-op) (rd 0) (funct #b011011))
            divmul-printer)
  (:dependencies (reads src1) (reads src2) (writes :hi-reg) (writes :low-reg))
  (:delay 1)
  (:emitter
   (emit-register-inst segment special-op (reg-tn-encoding src1)
                       (reg-tn-encoding src2) 0 0 #b011011)))

(define-instruction mult (segment src1 src2)
  (:declare (type tn src1 src2))
  (:printer register ((op special-op) (rd 0) (funct #b011000)) divmul-printer)
  (:dependencies (reads src1) (reads src2) (writes :hi-reg) (writes :low-reg))
  (:delay 1)
  (:emitter
   (emit-register-inst segment special-op (reg-tn-encoding src1)
                       (reg-tn-encoding src2) 0 0 #b011000)))

(define-instruction multu (segment src1 src2)
  (:declare (type tn src1 src2))
  (:printer register ((op special-op) (rd 0) (funct #b011001)))
  (:dependencies (reads src1) (reads src2) (writes :hi-reg) (writes :low-reg))
  (:delay 1)
  (:emitter
   (emit-register-inst segment special-op (reg-tn-encoding src1)
                       (reg-tn-encoding src2) 0 0 #b011001)))

(defun emit-shift-inst (segment opcode dst src1 src2)
  (unless src2
    (setf src2 src1)
    (setf src1 dst))
  (etypecase src2
    (tn
     (emit-register-inst segment special-op (reg-tn-encoding src2)
                         (reg-tn-encoding src1) (reg-tn-encoding dst)
                         0 (logior #b000100 opcode)))
    ((unsigned-byte 5)
     (emit-register-inst segment special-op 0 (reg-tn-encoding src1)
                         (reg-tn-encoding dst) src2 opcode))))

(defconstant-eqx shift-printer
  '(:name :tab
          rd
          (:unless (:same-as rd) ", " rt)
          ", " (:cond ((rs :constant 0) shamt)
                      (t rs)))
  #'equalp)

(define-instruction sll (segment dst src1 &optional src2)
  (:declare (type tn dst)
            (type (or tn (unsigned-byte 5) null) src1 src2))
  (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000000))
            shift-printer)
  (:printer register ((op special-op) (funct #b000100)) shift-printer)
  (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
  (:delay 0)
  (:emitter
   (emit-shift-inst segment #b00 dst src1 src2)))

(define-instruction sra (segment dst src1 &optional src2)
  (:declare (type tn dst)
            (type (or tn (unsigned-byte 5) null) src1 src2))
  (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000011))
            shift-printer)
  (:printer register ((op special-op) (funct #b000111)) shift-printer)
  (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
  (:delay 0)
  (:emitter
   (emit-shift-inst segment #b11 dst src1 src2)))

(define-instruction srl (segment dst src1 &optional src2)
  (:declare (type tn dst)
            (type (or tn (unsigned-byte 5) null) src1 src2))
  (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000010))
            shift-printer)
  (:printer register ((op special-op) (funct #b000110)) shift-printer)
  (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
  (:delay 0)
  (:emitter
   (emit-shift-inst segment #b10 dst src1 src2)))


;;;; Floating point math.

(define-instruction float-op (segment operation format dst src1 src2)
  (:declare (type float-operation operation)
            (type float-format format)
            (type tn dst src1 src2))
  (:printer float-op ())
  (:dependencies (reads src1) (reads src2) (writes dst))
  (:delay 0)
  (:emitter
   (emit-float-inst segment cop1-op 1 (float-format-value format)
                    (fp-reg-tn-encoding src2) (fp-reg-tn-encoding src1)
                    (fp-reg-tn-encoding dst) (float-operation operation))))

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

(define-instruction fabs (segment format dst &optional (src dst))
  (:declare (type float-format format) (type tn dst src))
  (:printer float ((funct #b000101)) float-unop-printer)
  (:dependencies (reads src) (writes dst))
  (:delay 0)
  (:emitter
   (emit-float-inst segment cop1-op 1 (float-format-value format)
                    0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
                    #b000101)))

(define-instruction fneg (segment format dst &optional (src dst))
  (:declare (type float-format format) (type tn dst src))
  (:printer float ((funct #b000111)) float-unop-printer)
  (:dependencies (reads src) (writes dst))
  (:delay 0)
  (:emitter
   (emit-float-inst segment cop1-op 1 (float-format-value format)
                    0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
                    #b000111)))

(define-instruction fcvt (segment format1 format2 dst src)
  (:declare (type float-format format1 format2) (type tn dst src))
  (:printer float-aux ((funct #b10) (sub-funct nil :type 'float-format))
           `(:name "." sub-funct "." format :tab fd ", " fs))
  (:dependencies (reads src) (writes dst))
  (:delay 0)
  (:emitter
   (emit-float-inst segment cop1-op 1 (float-format-value format2) 0
                    (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
                    (logior #b100000 (float-format-value format1)))))

(define-instruction fcmp (segment operation format fs ft)
  (:declare (type compare-kind operation)
            (type float-format format)
            (type tn fs ft))
  (:printer float-aux ((fd 0) (funct #b11) (sub-funct nil :type 'compare-kind))
            `(:name "-" sub-funct "." format :tab fs ", " ft))
  (:dependencies (reads fs) (reads ft) (writes :float-status))
  (:delay 1)
  (:emitter
   (emit-float-inst segment cop1-op 1 (float-format-value format)
                    (fp-reg-tn-encoding ft) (fp-reg-tn-encoding fs) 0
                    (logior #b110000 (compare-kind operation)))))


;;;; Branch/Jump instructions.

(defun emit-relative-branch (segment opcode r1 r2 target)
  (emit-chooser
   segment 20 2
      #'(lambda (segment posn magic-value)
          (declare (ignore magic-value))
          (let ((delta (ash (- (label-position target) (+ posn 4)) -2)))
            (when (typep delta '(signed-byte 16))
              (emit-back-patch segment 4
                #'(lambda (segment posn)
                    (emit-immediate-inst segment
                                         opcode
                                         (if (fixnump r1)
                                             r1
                                             (reg-tn-encoding r1))
                                         (if (fixnump r2)
                                             r2
                                             (reg-tn-encoding r2))
                                         (ash (- (label-position target)
                                                 (+ posn 4))
                                              -2))))
              t)))
      #'(lambda (segment posn)
          (declare (ignore posn))
          (let ((linked))
            ;; invert branch condition
            (if (or (= opcode bcond-op) (= opcode cop1-op))
                (setf r2 (logxor r2 #b00001))
                (setf opcode (logxor opcode #b00001)))
            ;; check link flag
            (if (= opcode bcond-op)
                (if (logand r2 #b10000)
                    (progn (setf r2 (logand r2 #b01111))
                           (setf linked t))))
            (emit-immediate-inst segment
                                 opcode
                                 (if (fixnump r1) r1 (reg-tn-encoding r1))
                                 (if (fixnump r2) r2 (reg-tn-encoding r2))
                                 4)
            (emit-nop segment)
            (emit-back-patch segment 8
              #'(lambda (segment posn)
                  (declare (ignore posn))
                  (emit-immediate-inst segment #b001111 0
                                       (reg-tn-encoding lip-tn)
                                       (ldb (byte 16 16)
                                            (label-position target)))
                  (emit-immediate-inst segment #b001101 0
                                       (reg-tn-encoding lip-tn)
                                       (ldb (byte 16 0)
                                            (label-position target)))))
            (emit-register-inst segment special-op (reg-tn-encoding lip-tn)
                                0 (if linked 31 0) 0
                                (if linked #b001001 #b001000))))))

(define-instruction b (segment target)
  (:declare (type label target))
  (:printer immediate ((op #b000100) (rs 0) (rt 0)
                       (immediate nil :type 'relative-label))
            '(:name :tab immediate))
  (:attributes branch)
  (:delay 1)
  (:emitter
   (emit-relative-branch segment #b000100 0 0 target)))

(define-instruction bal (segment target)
  (:declare (type label target))
  (:printer immediate ((op bcond-op) (rs 0) (rt #b01001)
                       (immediate nil :type 'relative-label))
            '(:name :tab immediate))
  (:attributes branch)
  (:dependencies (writes lip-tn))
  (:delay 1)
  (:emitter
   (emit-relative-branch segment bcond-op 0 #b10001 target)))

(define-instruction beq (segment r1 r2-or-target &optional target)
  (:declare (type tn r1)
            (type (or tn fixnum label) r2-or-target)
            (type (or label null) target))
  (:printer immediate ((op #b000100) (immediate nil :type 'relative-label)))
  (:attributes branch)
  (:dependencies (reads r1) (if target (reads r2-or-target)))
  (:delay 1)
  (:emitter
   (unless target
     (setf target r2-or-target)
     (setf r2-or-target 0))
   (emit-relative-branch segment #b000100 r1 r2-or-target target)))

(define-instruction bne (segment r1 r2-or-target &optional target)
  (:declare (type tn r1)
            (type (or tn fixnum label) r2-or-target)
            (type (or label null) target))
  (:printer immediate ((op #b000101) (immediate nil :type 'relative-label)))
  (:attributes branch)
  (:dependencies (reads r1) (if target (reads r2-or-target)))
  (:delay 1)
  (:emitter
   (unless target
     (setf target r2-or-target)
     (setf r2-or-target 0))
   (emit-relative-branch segment #b000101 r1 r2-or-target target)))

(defconstant-eqx cond-branch-printer
  '(:name :tab rs ", " immediate)