insts.lisp

开源跨平台Lisp编译器

   (multiple-value-bind
       (value-encoding double-p)
       (fp-reg-tn-encoding value)
     (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 1
                         (or side 0) (if modify 1 0) value-encoding))))

(define-instruction flds (segment disp base result &key modify side)
  (:declare (type tn base result)
            (type (signed-byte 5) disp)
            (type (member :before :after nil) modify)
            (type (member nil 0 1) side))
  (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
            `('FLDDS ,@cmplt-disp-print :tab x "(" s b ")," t))
  (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
            `('FLDWS ,@cmplt-disp-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)
                         (short-disp-encoding segment disp) 0
                         (if (eq modify :before) 1 0) 1 0 0
                         (or side 0) (if modify 1 0) result-encoding))))

(define-instruction fsts (segment value disp base &key modify side)
  (:declare (type tn base value)
            (type (signed-byte 5) disp)
            (type (member :before :after nil) modify)
            (type (member nil 0 1) side))
  (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
            `('FSTDS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
  (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
            `('FSTWS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
  (:emitter
   (multiple-value-bind
       (value-encoding double-p)
       (fp-reg-tn-encoding value)
     (when side
       (aver double-p)
       (setf double-p nil))
     (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
                         (short-disp-encoding segment disp) 0
                         (if (eq modify :before) 1 0) 1 0 1
                         (or side 0) (if modify 1 0) value-encoding))))


(define-bitfield-emitter emit-fp-class-0-inst 32
  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
  (byte 3 6) (byte 1 5) (byte 5 0))

(define-bitfield-emitter emit-fp-class-1-inst 32
  (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
  (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))

;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
;;; seperate emitters.

(defconstant-eqx funops '(:copy :abs :sqrt :rnd)
  #'equalp)

(deftype funop ()
  `(member ,@funops))

(define-instruction funop (segment op from to)
  (:declare (type funop op)
            (type tn from to))
  (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
            '('FCPY fmt :tab r "," t))
  (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
            '('FABS fmt  :tab r "," t))
  (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0))
            '('FSQRT fmt :tab r "," t))
  (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0))
            '('FRND fmt :tab r "," t))
  (:emitter
   (multiple-value-bind
       (from-encoding from-double-p)
       (fp-reg-tn-encoding from)
     (multiple-value-bind
         (to-encoding to-double-p)
         (fp-reg-tn-encoding to)
       (aver (eq from-double-p to-double-p))
       (emit-fp-class-0-inst segment #x0C from-encoding 0
                             (+ 2 (or (position op funops)
                                      (error "Bogus FUNOP: ~S" op)))
                             (if to-double-p 1 0) 0 0 0 to-encoding)))))

(macrolet ((define-class-1-fp-inst (name subcode)
               `(define-instruction ,name (segment from to)
                 (:declare (type tn from to))
                 (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
                  '(:name sf df :tab r "," t))
                 (:emitter
                  (multiple-value-bind
                        (from-encoding from-double-p)
                      (fp-reg-tn-encoding from)
                    (multiple-value-bind
                          (to-encoding to-double-p)
                        (fp-reg-tn-encoding to)
                      (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
                                            (if to-double-p 1 0) (if from-double-p 1 0)
                                            1 0 0 to-encoding)))))))

  (define-class-1-fp-inst fcnvff 0)
  (define-class-1-fp-inst fcnvxf 1)
  (define-class-1-fp-inst fcnvfx 2)
  (define-class-1-fp-inst fcnvfxt 3))

(define-instruction fcmp (segment cond r1 r2)
  (:declare (type (unsigned-byte 5) cond)
            (type tn r1 r2))
  (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
            '(:name fmt t :tab r "," x1))
  (:emitter
   (multiple-value-bind
       (r1-encoding r1-double-p)
       (fp-reg-tn-encoding r1)
     (multiple-value-bind
         (r2-encoding r2-double-p)
         (fp-reg-tn-encoding r2)
       (aver (eq r1-double-p r2-double-p))
       (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
                             (if r1-double-p 1 0) 2 0 0 cond)))))

(define-instruction ftest (segment)
  (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
  (:emitter
   (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))

(defconstant-eqx fbinops '(:add :sub :mpy :div)
  #'equalp)

(deftype fbinop ()
  `(member ,@fbinops))

(define-instruction fbinop (segment op r1 r2 result)
  (:declare (type fbinop op)
            (type tn r1 r2 result))
  (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
            '('FADD fmt :tab r "," x1 "," t))
  (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
            '('FSUB fmt :tab r "," x1 "," t))
  (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3))
            '('FMPY fmt :tab r "," x1 "," t))
  (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3))
            '('FDIV fmt :tab r "," x1 "," t))
  (:emitter
   (multiple-value-bind
       (r1-encoding r1-double-p)
       (fp-reg-tn-encoding r1)
     (multiple-value-bind
         (r2-encoding r2-double-p)
         (fp-reg-tn-encoding r2)
       (aver (eq r1-double-p r2-double-p))
       (multiple-value-bind
           (result-encoding result-double-p)
           (fp-reg-tn-encoding result)
         (aver (eq r1-double-p result-double-p))
         (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
                               (or (position op fbinops)
                                   (error "Bogus FBINOP: ~S" op))
                               (if r1-double-p 1 0) 3 0 0
                               result-encoding))))))



;;;; Instructions built out of other insts.

(define-instruction-macro move (src dst &optional cond)
  `(inst or ,src zero-tn ,dst ,cond))

(define-instruction-macro nop (&optional cond)
  `(inst or zero-tn zero-tn zero-tn ,cond))

(define-instruction li (segment value reg)
  (:declare (type tn reg)
            (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
  (:vop-var vop)
  (:emitter
   (assemble (segment vop)
     (etypecase value
       (fixup
        (inst ldil value reg)
        (inst ldo value reg reg))
       ((signed-byte 14)
        (inst ldo value zero-tn reg))
       ((or (signed-byte 32) (unsigned-byte 32))
        (let ((hi (ldb (byte 21 11) value))
              (lo (ldb (byte 11 0) value)))
          (inst ldil hi reg)
          (unless (zerop lo)
            (inst ldo lo reg reg))))))))

(define-instruction-macro sll (src count result &optional cond)
  (once-only ((result result) (src src) (count count) (cond cond))
    `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))

(define-instruction-macro sra (src count result &optional cond)
  (once-only ((result result) (src src) (count count) (cond cond))
    `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))

(define-instruction-macro srl (src count result &optional cond)
  (once-only ((result result) (src src) (count count) (cond cond))
    `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))

(defun maybe-negate-cond (cond negate)
  (if negate
      (multiple-value-bind
          (value negate)
          (compare-condition cond)
        (if negate
            (nth value compare-conditions)
            (nth (+ value 8) compare-conditions)))
      cond))

(define-instruction bc (segment cond not-p r1 r2 target)
  (:declare (type compare-condition cond)
            (type (member t nil) not-p)
            (type tn r1 r2)
            (type label target))
  (:vop-var vop)
  (:emitter
   (emit-chooser segment 8 2
     #'(lambda (segment posn delta)
         (let ((disp (label-relative-displacement target posn delta)))
           (when (<= 0 disp (1- (ash 1 11)))
             (assemble (segment vop)
               (inst comb (maybe-negate-cond cond not-p) r1 r2 target
                     :nullify t))
             t)))
     #'(lambda (segment posn)
         (let ((disp (label-relative-displacement target posn)))
           (assemble (segment vop)
             (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
                    (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
                    (inst nop))
                   (t
                    (inst comclr r1 r2 zero-tn
                          (maybe-negate-cond cond (not not-p)))
                    (inst b target :nullify t)))))))))

(define-instruction bci (segment cond not-p imm reg target)
  (:declare (type compare-condition cond)
            (type (member t nil) not-p)
            (type (signed-byte 11) imm)
            (type tn reg)
            (type label target))
  (:vop-var vop)
  (:emitter
   (emit-chooser segment 8 2
     #'(lambda (segment posn delta-if-after)
         (let ((disp (label-relative-displacement target posn delta-if-after)))
           (when (and (<= 0 disp (1- (ash 1 11)))
                      (<= (- (ash 1 4)) imm (1- (ash 1 4))))
             (assemble (segment vop)
               (inst comib (maybe-negate-cond cond not-p) imm reg target
                     :nullify t))
             t)))
     #'(lambda (segment posn)
         (let ((disp (label-relative-displacement target posn)))
           (assemble (segment vop)
             (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
                         (<= (- (ash 1 4)) imm (1- (ash 1 4))))
                    (inst comib (maybe-negate-cond cond not-p) imm reg target)
                    (inst nop))
                   (t
                    (inst comiclr imm reg zero-tn
                          (maybe-negate-cond cond (not not-p)))
                    (inst b target :nullify t)))))))))


;;;; Instructions to convert between code ptrs, functions, and lras.

(defun emit-compute-inst (segment vop src label temp dst calc)
  (emit-chooser
      ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
      segment 12 3
    #'(lambda (segment posn delta-if-after)
        (let ((delta (funcall calc label posn delta-if-after)))
          (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
            (emit-back-patch segment 4
                             #'(lambda (segment posn)
                                 (assemble (segment vop)
                                   (inst addi (funcall calc label posn 0) src
                                         dst))))
            t)))
    #'(lambda (segment posn)
        (let ((delta (funcall calc label posn 0)))
          ;; Note: if we used addil/ldo to do this in 2 instructions then the
          ;; intermediate value would be tagged but pointing into space.
          (assemble (segment vop)
            (inst ldil (ldb (byte 21 11) delta) temp)
            (inst ldo (ldb (byte 11 0) delta) temp temp)
            (inst add src temp dst))))))

;; code = lip - header - label-offset + other-pointer-tag
(define-instruction compute-code-from-lip (segment src label temp dst)
  (:declare (type tn src dst temp)
            (type label label))
  (:vop-var vop)
  (:emitter
   (emit-compute-inst segment vop src label temp dst
                      #'(lambda (label posn delta-if-after)
                          (- other-pointer-lowtag
                             (label-position label posn delta-if-after)
                             (component-header-length))))))

;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
;;      = lra - (header + label-offset)
(define-instruction compute-code-from-lra (segment src label temp dst)
  (:declare (type tn src dst temp)
            (type label label))
  (:vop-var vop)
  (:emitter
   (emit-compute-inst segment vop src label temp dst
                      #'(lambda (label posn delta-if-after)
                          (- (+ (label-position label posn delta-if-after)
                                (component-header-length)))))))

;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
;;     = code + header + label-offset
(define-instruction compute-lra-from-code (segment src label temp dst)
  (:declare (type tn src dst temp)
            (type label label))
  (:vop-var vop)
  (:emitter
   (emit-compute-inst segment vop src label temp dst
                      #'(lambda (label posn delta-if-after)
                          (+ (label-position label posn delta-if-after)
                             (component-header-length))))))


;;;; Data instructions.

(define-instruction byte (segment byte)
  (:emitter
   (emit-byte segment byte)))

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

(define-instruction halfword (segment halfword)
  (:emitter
   (emit-halfword segment halfword)))

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

(define-instruction word (segment word)
  (:emitter
   (emit-word segment word)))

(define-instruction fun-header-word (segment)
  (:emitter
   (emit-back-patch
    segment 4
    #'(lambda (segment posn)
        (emit-word segment
                   (logior simple-fun-header-widetag
                           (ash (+ posn (component-header-length))
                                (- n-widetag-bits word-shift))))))))

(define-instruction lra-header-word (segment)
  (:emitter
   (emit-back-patch
    segment 4
    #'(lambda (segment posn)
        (emit-word segment
                   (logior return-pc-header-widetag
                           (ash (+ posn (component-header-length))
                                (- n-widetag-bits word-shift))))))))