insts.lisp

开源跨平台Lisp编译器

  (define-operate sll    #x12 #x39)
  (define-operate extbl  #x12 #x06)
  (define-operate extwl  #x12 #x16)
  (define-operate extll  #x12 #x26)
  (define-operate extql  #x12 #x36)
  (define-operate extwh  #x12 #x5a)
  (define-operate extlh  #x12 #x6a)
  (define-operate extqh  #x12 #x7a)
  (define-operate sra    #x12 #x3c)
  (define-operate insbl  #x12 #x0b)
  (define-operate inswl  #x12 #x1b)
  (define-operate insll  #x12 #x2b)
  (define-operate insql  #x12 #x3b)
  (define-operate inswh  #x12 #x57)
  (define-operate inslh  #x12 #x67)
  (define-operate insqh  #x12 #x77)
  (define-operate srl    #x12 #x34)
  (define-operate mskbl  #x12 #x02)
  (define-operate mskwl  #x12 #x12)
  (define-operate mskll  #x12 #x22)
  (define-operate mskql  #x12 #x32)
  (define-operate mskwh  #x12 #x52)
  (define-operate msklh  #x12 #x62)
  (define-operate mskqh  #x12 #x72)
  (define-operate zap    #x12 #x30)
  (define-operate zapnot #x12 #x31)

  (define-operate mull   #x13 #x00)
  (define-operate mulq/v #x13 #x60)
  (define-operate mull/v #x13 #x40)
  (define-operate umulh  #x13 #x30)
  (define-operate mulq   #x13 #x20)

  (define-operate ctpop  #x1c #x30)     ; CIX extension
  (define-operate ctlz   #x1c #x32)     ; CIX extension
  (define-operate cttz   #x1c #x33))    ; CIX extension


(macrolet ((define-fp-operate (name op fn &optional (args 3))
             `(define-instruction ,name (segment ,@(when (= args 3) '(fa)) fb fc)
                (:declare (type tn ,@(when (= args 3) '(fa)) fb fc))
                (:printer fp-operate ((op ,op) (fn ,fn) ,@(when (= args 2) '((fa 31))))
                          ,@(when (= args 2)
                              '('(:name :tab fb "," fc))))
                ,@(when (and (= op #x17) (= fn #x20))
                    `((:printer fp-operate ((op ,op) (fn ,fn) (fa 31))
                                '('fabs :tab fb "," fc))))
                (:emitter
                 (emit-fp-operate segment ,op ,@(if (= args 3)
                                                    '((fp-reg-tn-encoding fa))
                                                  '(31))
                                  (fp-reg-tn-encoding fb) ,fn (fp-reg-tn-encoding fc))))))
  (define-fp-operate cpys     #x17 #x020)
  (define-fp-operate mf_fpcr  #x17 #x025)
  (define-fp-operate cpysn    #x17 #x021)
  (define-fp-operate mt_fpcr  #x17 #x024)
  (define-fp-operate cpyse    #x17 #x022)
  (define-fp-operate cvtql/sv #x17 #x530 2)
  (define-fp-operate cvtlq    #x17 #x010 2)
  (define-fp-operate cvtql    #x17 #x030 2)
  (define-fp-operate cvtql/v  #x17 #x130 2)
  (define-fp-operate fcmoveq  #x17 #x02a)
  (define-fp-operate fcmovne  #x17 #x02b)
  (define-fp-operate fcmovlt  #x17 #x02c)
  (define-fp-operate fcmovge  #x17 #x02d)
  (define-fp-operate fcmovle  #x17 #x02e)
  (define-fp-operate fcmovgt  #x17 #x02f)

  (define-fp-operate cvtqs #x16 #x0bc 2)
  (define-fp-operate cvtqt #x16 #x0be 2)
  (define-fp-operate cvtts #x16 #x0ac 2)
  (define-fp-operate cvttq #x16 #x0af 2)
  (define-fp-operate cvttq/c #x16 #x02f 2)
  (define-fp-operate cmpteq #x16 #x5a5)
  (define-fp-operate cmptlt #x16 #x5a6)
  (define-fp-operate cmptle #x16 #x5a7)
  (define-fp-operate cmptun #x16 #x5a4)
  (define-fp-operate adds #x16 #x080)
  (define-fp-operate addt #x16 #x0a0)
  (define-fp-operate divs #x16 #x083)
  (define-fp-operate divt #x16 #x0a3)
  (define-fp-operate muls #x16 #x082)
  (define-fp-operate mult #x16 #x0a2)
  (define-fp-operate subs #x16 #x081)
  (define-fp-operate subt #x16 #x0a1)

;;; IEEE support
  (def!constant +su+   #x500)           ; software, underflow enabled
  (def!constant +sui+  #x700)           ; software, inexact & underflow enabled
  (def!constant +sv+   #x500)           ; software, interger overflow enabled
  (def!constant +svi+  #x700)
  (def!constant +rnd+  #x0c0)           ; dynamic rounding mode
  (def!constant +sud+  #x5c0)
  (def!constant +svid+ #x7c0)
  (def!constant +suid+ #x7c0)

  (define-fp-operate cvtqs_su #x16 (logior +su+ #x0bc) 2)
  (define-fp-operate cvtqs_sui #x16 (logior +sui+ #x0bc) 2)
  (define-fp-operate cvtqt_su #x16 (logior +su+ #x0be) 2)
  (define-fp-operate cvtqt_sui #x16 (logior +sui+ #x0be) 2)
  (define-fp-operate cvtts_su #x16 (logior +su+ #x0ac) 2)

  (define-fp-operate cvttq_sv #x16 (logior +su+ #x0af) 2)
  (define-fp-operate cvttq/c_sv #x16 (logior +su+ #x02f) 2)

  (define-fp-operate adds_su #x16 (logior +su+ #x080))
  (define-fp-operate addt_su #x16 (logior +su+ #x0a0))
  (define-fp-operate divs_su #x16 (logior +su+ #x083))
  (define-fp-operate divt_su #x16 (logior +su+ #x0a3))
  (define-fp-operate muls_su #x16 (logior +su+ #x082))
  (define-fp-operate mult_su #x16 (logior +su+ #x0a2))
  (define-fp-operate subs_su #x16 (logior +su+ #x081))
  (define-fp-operate subt_su #x16 (logior +su+ #x0a1)))

(define-instruction  excb (segment)
  (:emitter (emit-lword segment #x63ff0400)))

(define-instruction trapb (segment)
  (:emitter (emit-lword segment #x63ff0000)))

(define-instruction imb (segment)
  (:emitter (emit-lword segment #x00000086)))

(define-instruction gentrap (segment code)
  (:printer call-pal ((palcode #xaa0000)))
  (:emitter
   (emit-lword segment #x000081)        ;actually bugchk
   (emit-lword segment code)))

(define-instruction-macro move (src dst)
  `(inst bis zero-tn ,src ,dst))

(define-instruction-macro not (src dst)
  `(inst ornot zero-tn ,src ,dst))

(define-instruction-macro fmove (src dst)
  `(inst cpys ,src ,src ,dst))

(define-instruction-macro fabs (src dst)
  `(inst cpys fp-single-zero-tn ,src ,dst))

(define-instruction-macro fneg (src dst)
  `(inst cpysn ,src ,src ,dst))

(define-instruction-macro nop ()
  `(inst bis zero-tn zero-tn zero-tn))

(defun %li (value reg)
  (etypecase value
    ((signed-byte 16)
     (inst lda reg value zero-tn))
    ((signed-byte 32)
     (flet ((se (x n)
              (let ((x (logand x (lognot (ash -1 n)))))
                (if (logbitp (1- n) x)
                    (logior (ash -1 (1- n)) x)
                    x))))
       (let* ((value (se value 32))
              (low (ldb (byte 16 0) value))
              (tmp1 (- value (se low 16)))
              (high (ldb (byte 16 16) tmp1))
              (tmp2 (- tmp1 (se (ash high 16) 32)))
              (extra 0))
         (unless (= tmp2 0)
           (setf extra #x4000)
           (setf tmp1 (- tmp1 #x40000000))
           (setf high (ldb (byte 16 16) tmp1)))
         (inst lda reg low zero-tn)
         (unless (= extra 0)
           (inst ldah reg extra reg))
         (unless (= high 0)
           (inst ldah reg high reg)))))
    ((or (unsigned-byte 32) (signed-byte 64) (unsigned-byte 64))
     ;; Since it took NJF and CSR a good deal of puzzling to work out
     ;; (a) what a previous version of this was doing and (b) why it
     ;; was wrong:
     ;;
     ;; write VALUE = a_63 * 2^63 + a_48-62 * 2^48
     ;;               + a_47 * 2^47 + a_32-46 * 2^32
     ;;               + a_31 * 2^31 + a_16-30 * 2^16
     ;;               + a_15 * 2^15 + a_0-14
     ;;
     ;; then, because of the wonders of sign-extension and
     ;; twos-complement arithmetic modulo 2^64, if a_15 is set, LDA
     ;; (which sign-extends its argument) will add
     ;;
     ;;    (a_15 * 2^15 + a_0-14 - 65536).
     ;;
     ;; So we need to add that 65536 back on, which is what this
     ;; LOGBITP business is doing.  The same applies for bits 31 and
     ;; 47 (bit 63 is taken care of by the fact that all of this
     ;; arithmetic is mod 2^64 anyway), but we have to be careful that
     ;; we consider the altered value, not the original value.
     ;;
     ;; I think, anyway.  -- CSR, 2003-09-26
     (let* ((value1 (if (logbitp 15 value) (+ value (ash 1 16)) value))
            (value2 (if (logbitp 31 value1) (+ value1 (ash 1 32)) value1))
            (value3 (if (logbitp 47 value2) (+ value2 (ash 1 48)) value2)))
       (inst lda reg (ldb (byte 16 32) value2) zero-tn)
       ;; FIXME: Don't yet understand these conditionals.  If I'm
       ;; right, surely we can just consider the zeroness of the
       ;; particular bitfield, not the zeroness of the whole thing?
       ;; -- CSR, 2003-09-26
       (unless (= value3 0)
         (inst ldah reg (ldb (byte 16 48) value3) reg))
       (unless (and (= value2 0) (= value3 0))
         (inst sll reg 32 reg))
       (unless (= value 0)
         (inst lda reg (ldb (byte 16 0) value) reg))
       (unless (= value1 0)
         (inst ldah reg (ldb (byte 16 16) value1) reg))))
    (fixup
     (inst lda reg value zero-tn :bits-47-32)
     (inst ldah reg value reg :bits-63-48)
     (inst sll reg 32 reg)
     (inst lda reg value reg)
     (inst ldah reg value reg))))

(define-instruction-macro li (value reg)
  `(%li ,value ,reg))


;;;;

(define-instruction lword (segment lword)
  (:declare (type (or (unsigned-byte 32) (signed-byte 32)) lword))
  (:cost 0)
  (:emitter
   (emit-lword segment lword)))

(define-instruction short (segment word)
  (:declare (type (or (unsigned-byte 16) (signed-byte 16)) word))
  (:cost 0)
  (:emitter
   (emit-word segment word)))

(define-instruction byte (segment byte)
  (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
  (:cost 0)
  (:emitter
   (emit-byte segment byte)))

(defun emit-header-data (segment type)
  (emit-back-patch
   segment 4
   (lambda (segment posn)
     (emit-lword segment
                 (logior type
                         (ash (+ posn (component-header-length))
                              (- n-widetag-bits word-shift)))))))

(define-instruction simple-fun-header-word (segment)
  (:cost 0)
  (:emitter
   (emit-header-data segment simple-fun-header-widetag)))

(define-instruction lra-header-word (segment)
  (:cost 0)
  (:emitter
   (emit-header-data segment return-pc-header-widetag)))

(defun emit-compute-inst (segment vop dst src label temp calc)
  (declare (ignore temp))
  (emit-chooser
   ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
   segment 12 3
   (lambda (segment posn delta-if-after)
     (let ((delta (funcall calc label posn delta-if-after)))
       (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
         (emit-back-patch segment 4
                          (lambda (segment posn)
                            (assemble (segment vop)
                                      (inst lda dst
                                            (funcall calc label posn 0)
                                            src))))
         t)))
   (lambda (segment posn)
     (assemble (segment vop)
               (flet ((se (x n)
                          (let ((x (logand x (lognot (ash -1 n)))))
                            (if (logbitp (1- n) x)
                                (logior (ash -1 (1- n)) x)
                                x))))
                 (let* ((value (se (funcall calc label posn 0) 32))
                        (low (ldb (byte 16 0) value))
                        (tmp1 (- value (se low 16)))
                        (high (ldb (byte 16 16) tmp1))
                        (tmp2 (- tmp1 (se (ash high 16) 32)))
                        (extra 0))
                   (unless (= tmp2 0)
                     (setf extra #x4000)
                     (setf tmp1 (- tmp1 #x40000000))
                     (setf high (ldb (byte 16 16) tmp1)))
                   (inst lda dst low src)
                   (inst ldah dst extra dst)
                   (inst ldah dst high dst)))))))

;; code = lip - header - label-offset + other-pointer-tag
(define-instruction compute-code-from-lip (segment dst src label temp)
  (:declare (type tn dst src temp) (type label label))
  (:vop-var vop)
  (:emitter
   (emit-compute-inst segment vop dst src label temp
                      (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 dst src label temp)
  (:declare (type tn dst src temp) (type label label))
  (:vop-var vop)
  (:emitter
   (emit-compute-inst segment vop dst src label temp
                      (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 dst src label temp)
  (:declare (type tn dst src temp) (type label label))
  (:vop-var vop)
  (:emitter
   (emit-compute-inst segment vop dst src label temp
                      (lambda (label posn delta-if-after)
                        (+ (label-position label posn delta-if-after)
                           (component-header-length))))))