insts.lisp

开源跨平台Lisp编译器

(define-instruction ble (segment disp space base &key nullify)
  (:declare (type (or fixup (signed-byte 17)) disp)
            (type tn base)
            (type (unsigned-byte 3) space)
            (type (member t nil) nullify))
  (:printer branch17 ((op1 #x39) (op2 nil :type 'im3))
            '(:name n :tab w "(" op2 "," t ")"))
  (:emitter
   (multiple-value-bind
       (w1 w2 w)
       (decompose-branch-disp segment disp)
     (emit-branch segment #x39 (reg-tn-encoding base) w1
                  (space-encoding space) w2 (if nullify 1 0) w))))

(defun emit-conditional-branch (segment opcode r2 r1 cond target nullify)
  (emit-back-patch segment 4
    #'(lambda (segment posn)
        (let ((disp (label-relative-displacement target posn)))
          (aver (<= (- (ash 1 11)) disp (1- (ash 1 11))))
          (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
                            (ldb (byte 1 10) disp)))
                (w (ldb (byte 1 11) disp)))
            (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))

(defun im5-encoding (value)
  (declare (type (signed-byte 5) value)
           #+nil (values (unsigned-byte 5)))
  (dpb (ldb (byte 4 0) value)
       (byte 4 1)
       (ldb (byte 1 4) value)))

(macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind)
               (let* ((conditional (symbolicate cond-kind "-CONDITION"))
                      (false-conditional (symbolicate conditional "-FALSE")))
                 `(progn
                   (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
                     (:declare (type ,conditional cond)
                      (type tn r1 r2)
                      (type label target)
                      (type (member t nil) nullify))
                     (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
                      '(:name c n :tab r1 "," r2 "," w))
                     ,@(unless (= r-opcode #x32)
                               `((:printer branch12 ((op1 ,(+ 2 r-opcode))
                                                     (c nil :type ',false-conditional))
                                  '(:name c n :tab r1 "," r2 "," w))))
                     (:emitter
                      (multiple-value-bind
                            (cond-encoding false)
                          (,conditional cond)
                        (emit-conditional-branch
                         segment (if false ,(+ r-opcode 2) ,r-opcode)
                         (reg-tn-encoding r2) (reg-tn-encoding r1)
                         cond-encoding target nullify))))
                   (define-instruction ,i-name (segment cond imm reg target &key nullify)
                     (:declare (type ,conditional cond)
                      (type (signed-byte 5) imm)
                      (type tn reg)
                      (type (member t nil) nullify))
                     (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
                                         (c nil :type ',conditional))
                      '(:name c n :tab r1 "," r2 "," w))
                     ,@(unless (= r-opcode #x32)
                               `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
                                                     (c nil :type ',false-conditional))
                                  '(:name c n :tab r1 "," r2 "," w))))
                     (:emitter
                      (multiple-value-bind
                            (cond-encoding false)
                          (,conditional cond)
                        (emit-conditional-branch
                         segment (if false (+ ,i-opcode 2) ,i-opcode)
                         (reg-tn-encoding reg) (im5-encoding imm)
                         cond-encoding target nullify))))))))
  (define-branch-inst movb #x32 movib #x33 extract/deposit)
  (define-branch-inst comb #x20 comib #x21 compare)
  (define-branch-inst addb #x28 addib #x29 add))

(define-instruction bb (segment cond reg posn target &key nullify)
  (:declare (type (member t nil) cond nullify)
            (type tn reg)
            (type (or (member :variable) (unsigned-byte 5)) posn))
  (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
                      '('BVB c n :tab r1 "," w))
  (:emitter
   (multiple-value-bind
       (opcode posn-encoding)
       (if (eq posn :variable)
           (values #x30 0)
           (values #x31 posn))
     (emit-conditional-branch segment opcode posn-encoding
                              (reg-tn-encoding reg)
                              (if cond 2 6) target nullify))))


;;;; Computation Instructions

(define-bitfield-emitter emit-r3-inst 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
  (byte 1 12) (byte 7 5) (byte 5 0))

(macrolet ((define-r3-inst (name cond-kind opcode)
               `(define-instruction ,name (segment r1 r2 res &optional cond)
                 (:declare (type tn res r1 r2))
                 (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
                                                                 cond-kind
                                                                 "-CONDITION"))))
                 ,@(when (= opcode #x12)
                         `((:printer r3-inst ((op ,opcode) (r2 0)
                                              (c nil :type ',(symbolicate cond-kind
                                                                          "-CONDITION")))
                            `('COPY :tab r1 "," t))))
                 (:emitter
                  (multiple-value-bind
                        (cond false)
                      (,(symbolicate cond-kind "-CONDITION") cond)
                    (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
                                  cond (if false 1 0) ,opcode
                                  (reg-tn-encoding res)))))))
  (define-r3-inst add add #x30)
  (define-r3-inst addl add #x50)
  (define-r3-inst addo add #x70)
  (define-r3-inst addc add #x38)
  (define-r3-inst addco add #x78)
  (define-r3-inst sh1add add #x32)
  (define-r3-inst sh1addl add #x52)
  (define-r3-inst sh1addo add #x72)
  (define-r3-inst sh2add add #x34)
  (define-r3-inst sh2addl add #x54)
  (define-r3-inst sh2addo add #x74)
  (define-r3-inst sh3add add #x36)
  (define-r3-inst sh3addl add #x56)
  (define-r3-inst sh3addo add #x76)
  (define-r3-inst sub compare #x20)
  (define-r3-inst subo compare #x60)
  (define-r3-inst subb compare #x28)
  (define-r3-inst subbo compare #x68)
  (define-r3-inst subt compare #x26)
  (define-r3-inst subto compare #x66)
  (define-r3-inst ds compare #x22)
  (define-r3-inst comclr compare #x44)
  (define-r3-inst or logical #x12)
  (define-r3-inst xor logical #x14)
  (define-r3-inst and logical #x10)
  (define-r3-inst andcm logical #x00)
  (define-r3-inst uxor unit #x1C)
  (define-r3-inst uaddcm unit #x4C)
  (define-r3-inst uaddcmt unit #x4E)
  (define-r3-inst dcor unit #x5C)
  (define-r3-inst idcor unit #x5E))

(define-bitfield-emitter emit-imm-inst 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
  (byte 1 12) (byte 1 11) (byte 11 0))

(defun im11-encoding (value)
  (declare (type (signed-byte 11) value)
           #+nil (values (unsigned-byte 11)))
  (dpb (ldb (byte 10 0) value)
       (byte 10 1)
       (ldb (byte 1 10) value)))

(macrolet ((define-imm-inst (name cond-kind opcode subcode)
               `(define-instruction ,name (segment imm src dst &optional cond)
                 (:declare (type tn dst src)
                  (type (signed-byte 11) imm))
                 (:printer imm-inst ((op ,opcode) (o ,subcode)
                                     (c nil :type
                                        ',(symbolicate cond-kind "-CONDITION"))))
                 (:emitter
                  (multiple-value-bind
                        (cond false)
                      (,(symbolicate cond-kind "-CONDITION") cond)
                    (emit-imm-inst segment ,opcode (reg-tn-encoding src)
                                   (reg-tn-encoding dst) cond
                                   (if false 1 0) ,subcode
                                   (im11-encoding imm)))))))
  (define-imm-inst addi add #x2D 0)
  (define-imm-inst addio add #x2D 1)
  (define-imm-inst addit add #x2C 0)
  (define-imm-inst addito add #x2C 1)
  (define-imm-inst subi compare #x25 0)
  (define-imm-inst subio compare #x25 1)
  (define-imm-inst comiclr compare #x24 0))

(define-bitfield-emitter emit-extract/deposit-inst 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
  (byte 3 10) (byte 5 5) (byte 5 0))

(define-instruction shd (segment r1 r2 count res &optional cond)
  (:declare (type tn res r1 r2)
            (type (or (member :variable) (integer 0 31)) count))
  (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
            '(:name c :tab r1 "," r2 "," cp "," t/clen))
  (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
            '('VSHD c :tab r1 "," r2 "," t/clen))
  (:emitter
   (etypecase count
     ((member :variable)
      (emit-extract/deposit-inst segment #x34
                                 (reg-tn-encoding r2) (reg-tn-encoding r1)
                                 (extract/deposit-condition cond)
                                 0 0 (reg-tn-encoding res)))
     ((integer 0 31)
      (emit-extract/deposit-inst segment #x34
                                 (reg-tn-encoding r2) (reg-tn-encoding r1)
                                 (extract/deposit-condition cond)
                                 2 (- 31 count)
                                 (reg-tn-encoding res))))))

(macrolet ((define-extract-inst (name opcode)
               `(define-instruction ,name (segment src posn len res &optional cond)
                 (:declare (type tn res src)
                  (type (or (member :variable) (integer 0 31)) posn)
                  (type (integer 1 32) len))
                 (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
                                                 (op2 ,opcode))
                  '(:name c :tab r2 "," cp "," t/clen "," r1))
                 (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
                  '('V :name c :tab r2 "," t/clen "," r1))
                 (:emitter
                  (etypecase posn
                    ((member :variable)
                     (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
                                                (reg-tn-encoding res)
                                                (extract/deposit-condition cond)
                                                ,(- opcode 2) 0 (- 32 len)))
                    ((integer 0 31)
                     (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
                                                (reg-tn-encoding res)
                                                (extract/deposit-condition cond)
                                                ,opcode posn (- 32 len))))))))
  (define-extract-inst extru 6)
  (define-extract-inst extrs 7))

(macrolet ((define-deposit-inst (name opcode)
               `(define-instruction ,name (segment src posn len res &optional cond)
                 (:declare (type tn res)
                  (type (or tn (signed-byte 5)) src)
                  (type (or (member :variable) (integer 0 31)) posn)
                  (type (integer 1 32) len))
                 (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
                  ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
                         (if (= opcode 0) (cons ''Z base) base)))
                 (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
                  ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
                         (if (= opcode 0) (cons ''Z base) base)))
                 (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
                                                 (op2 ,(+ 4 opcode)))
                  ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
                         (if (= opcode 0) (cons ''Z base) base)))
                 (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
                                                 (op2 ,(+ 6 opcode)))
                  ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
                         (if (= opcode 0) (cons ''Z base) base)))
                 (:emitter
                  (multiple-value-bind
                        (opcode src-encoding)
                      (etypecase src
                        (tn
                         (values ,opcode (reg-tn-encoding src)))
                        ((signed-byte 5)
                         (values ,(+ opcode 4) (im5-encoding src))))
                    (multiple-value-bind
                          (opcode posn-encoding)
                        (etypecase posn
                          ((member :variable)
                           (values opcode 0))
                          ((integer 0 31)
                           (values (+ opcode 2) (- 31 posn))))
                      (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
                                                 src-encoding
                                                 (extract/deposit-condition cond)
                                                 opcode posn-encoding (- 32 len))))))))

  (define-deposit-inst dep 1)
  (define-deposit-inst zdep 0))



;;;; System Control Instructions.

(define-bitfield-emitter emit-break 32
  (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))

(define-instruction break (segment &optional (im5 0) (im13 0))
  (:declare (type (unsigned-byte 13) im13)
            (type (unsigned-byte 5) im5))
  (:printer break () :default :control #'break-control)
  (:emitter
   (emit-break segment 0 im13 0 im5)))

(define-bitfield-emitter emit-system-inst 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))

(define-instruction ldsid (segment res base &optional (space 0))
  (:declare (type tn res base)
            (type (integer 0 3) space))
  (:printer system-inst ((op2 #x85) (c nil :type 'space)
                         (s nil  :printer #(0 0 1 1 2 2 3 3)))
            `(:name :tab "(" s r1 ")," r3))
  (:emitter
   (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
                     (reg-tn-encoding res))))

(define-instruction mtsp (segment reg space)
  (:declare (type tn reg) (type (integer 0 7) space))
  (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
  (:emitter
   (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
                     #xC1 0)))

(define-instruction mfsp (segment space reg)
  (:declare (type tn reg) (type (integer 0 7) space))
  (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3))
  (:emitter
   (emit-system-inst segment 0 0 0 (space-encoding space) #x25
                     (reg-tn-encoding reg))))

(deftype control-reg ()
  '(or (unsigned-byte 5) (member :sar)))

(defun control-reg (reg)
  (declare (type control-reg reg)
           #+nil (values (unsigned-byte 32)))
  (if (typep reg '(unsigned-byte 5))
      reg
      (ecase reg
        (:sar 11))))

(define-instruction mtctl (segment reg ctrl-reg)
  (:declare (type tn reg) (type control-reg ctrl-reg))
  (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
  (:emitter
   (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
                     0 #xC2 0)))

(define-instruction mfctl (segment ctrl-reg reg)
  (:declare (type tn reg) (type control-reg ctrl-reg))
  (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
  (:emitter
   (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
                     (reg-tn-encoding reg))))



;;;; Floating point instructions.

(define-bitfield-emitter emit-fp-load/store 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
  (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))

(define-instruction fldx (segment index base result &key modify scale side)
  (:declare (type tn index base result)
            (type (member t nil) modify scale)
            (type (member nil 0 1) side))
  (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
            `('FLDDX ,@cmplt-index-print :tab x "(" s b ")" "," t))
  (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
            `('FLDWX ,@cmplt-index-print :tab x "(" s b ")" "," t))
  (:emitter
   (multiple-value-bind
       (result-encoding double-p)
       (fp-reg-tn-encoding result)
     (when side
       (aver double-p)
       (setf double-p nil))
     (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
                         (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
                         (or side 0) (if modify 1 0) result-encoding))))

(define-instruction fstx (segment value index base &key modify scale side)
  (:declare (type tn index base value)
            (type (member t nil) modify scale)
            (type (member nil 0 1) side))
  (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
            `('FSTDX ,@cmplt-index-print :tab t "," x "(" s b ")"))
  (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
            `('FSTWX ,@cmplt-index-print :tab t "," x "(" s b ")"))
  (:emitter